0b3ca54 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Merge remote-tracking branch 'origin/develop' into factorDynGeneric-update

0b3ca54Ali Abrar8 years ago

.stylish-haskell.yaml+2−3

compare with develop

unifiedsplit

@@ -149,6 +149,5 @@ columns: 110

149# needs to be aware of these, so it can parse the file correctly.

150#

151# No language extensions are enabled by default.

152−# language_extensions:

152+language_extensions:

153− # - TemplateHaskell

153+ - TemplateHaskell

154− # - QuasiQuotes

.travis.ymldeleted−16

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

1−# Cache Buster: 0

2−language: nix

3−cache:

4− directories:

5− - /nix

6−matrix:

7− include:

8− - env: COMPILER=ghc7103

9− - env: COMPILER=ghc821

10− - env: COMPILER=ghc802

11− - env: COMPILER=ghcjs

12−script:

13− - set -e

14− - nix-build -E "with (import <nixpkgs> {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }"

15− - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed

16−

Quickref.md+36−11

@@ -30,7 +30,7 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

30[ ] ffilter :: (a -> Bool) -> Event a -> Event a

31[ ] ffor :: Event a -> (a -> b) -> Event b

32[ ] fforMaybe :: Event a -> (a -> Maybe b) -> Event b

33−[ ] <$ :: b -> Event a -> Event b

33+[ ] <$ :: a -> Event b -> Event a

35-- Event to identical Event with debug trace. (Only prints if Event is ultimately used.)

36[ ] traceEvent :: Show a => String -> Event a -> Event a

@@ -47,7 +47,7 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

47[ ] attachWithMaybe :: (a -> b -> Maybe c) -> Behavior a -> Event b -> Event c

48[ ] attachPromptlyDynWithMaybe :: (a -> b -> Maybe c) -> Dynamic a -> Event b -> Event c

49[ ] <@> :: Behavior (a -> b) -> Event a -> Event b

50−[ ] <@ :: Behavior b -> Event a -> Event b

50+[ ] <@ :: Behavior a -> Event b -> Event a

52-- Combine multiple Events

53[ ] <> :: Semigroup a => Event a -> Event a -> Event a

@@ -57,15 +57,15 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

57[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a

58[ ] leftmost :: [Event a] -> Event a

59[ ] mergeList :: [Event a] -> Event (NonEmpty a)

60−[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)

60+[ ] merge :: GCompare k => DMap k Event -> Event (DMap k Identity)

61[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)

63-- Efficient one-to-many fanout

64−[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)

64+[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)

65−[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k

65+[ ] fan :: GCompare k => Event (DMap k Identity) -> EventSelector k

66−[ ] select :: EventSelector k -> k a -> Event a

66+[ ] select :: EventSelector k -> k a -> Event a

67−[ ] fanEither :: Event (Either a b) -> (Event a, Event b)

67+[ ] fanEither :: Event (Either a b) -> (Event a, Event b)

68−[ ] fanThese :: Event (These a b) -> (Event a, Event b)

68+[ ] fanThese :: Event (These a b) -> (Event a, Event b)

70-- Event to Event via function that can sample current values

71[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b

@@ -98,6 +98,10 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

98[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a

99-- ... plus many more due to typeclass membership

100

101+-- Combine multiple behaviors via applicative instance

102+[ ] ffor2 :: Behavior a -> Behavior b -> (a -> b -> c) -> Behavior c

103+[ ] ffor3 :: Behavior a -> Behavior b -> Behavior c -> (a -> b -> c -> d) -> Behavior d

104+

101-- Behavior to Behavior by sampling current values

105-- Behavior to Behavior by sampling current values

102[S] sample :: Behavior a -> m a

106[S] sample :: Behavior a -> m a

103[ ] pull :: m a -> Behavior a

107[ ] pull :: m a -> Behavior a

@@ -135,6 +139,10 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

135[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b

139[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b

136[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c

140[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c

137

141

142+-- Combine multiple dynamics via applicative instance

143+[ ] ffor2 :: Dynamic a -> Dynamic b -> (a -> b -> c) -> Dynamic c

144+[ ] ffor3 :: Dynamic a -> Dynamic b -> Dynamic c -> (a -> b -> c -> d) -> Dynamic d

145+

138-- Efficient one-to-many fanout

146-- Efficient one-to-many fanout

139[ ] demux :: Ord k => Dynamic k -> Demux k

147[ ] demux :: Ord k => Dynamic k -> Demux k

140[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool

148[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool

@@ -159,7 +167,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w

159[ ] switch :: Behavior (Event a) -> Event a

167[ ] switch :: Behavior (Event a) -> Event a

160

168

161-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.

169-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.

162−[ ] switchPromptlyDyn :: Dynamic (Event a) -> Event a

170+[ ] switchDyn :: Dynamic (Event a) -> Event a

163

171

164-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.

172-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.

165[ ] coincidence :: Event (Event a) -> Event a

173[ ] coincidence :: Event (Event a) -> Event a

@@ -182,7 +190,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w

182

190

183-- Similar to above, for Events. Created Event initially tracks the first argument.

191-- Similar to above, for Events. Created Event initially tracks the first argument.

184-- At switchover, the output Event immediately tracks the new Event.

192-- At switchover, the output Event immediately tracks the new Event.

185−[H] switchPromptly :: Event a -> Event (Event a) -> m (Event a)

193+[H] switchHold :: Event a -> Event (Event a) -> m (Event a)

186```

194```

187

195

188## Typeclasses to introspect and modify an FRP network.

196## Typeclasses to introspect and modify an FRP network.

@@ -247,7 +255,7 @@ Th typeclasses and their associated annotations include:

247 Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k)

255 Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k)

248

256

249-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic.

257-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic.

250−[H,A,B] listWithKey' :: Ord k =>

258+[H,A] listWithKeyShallowDiff :: Ord k =>

251 Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a))

259 Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a))

252```

260```

253

261

@@ -284,3 +292,20 @@ Th typeclasses and their associated annotations include:

284[P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a)

292[P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a)

285```

293```

286

294

295+## Networks

296+

297+```haskell

298+-- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a)

299+

300+-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.

301+-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event,

302+-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold).

303+[P,A] networkView :: Dynamic (m a) -> m (Event a)

304+

305+-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the

306+-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an

307+-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

308+[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)

309+

310+-- Render a placeholder network to be shown while another network is not yet done building

311+[P,A] untilReady :: m a -> m b -> m (a, Event b)

bench-cbits/checkCapability.c+11−12

@@ -42,7 +42,7 @@ typedef struct Task_ {

42 // or just continue immediately. It's a workaround for the fact

43 // that signalling a condition variable doesn't do anything if the

44 // thread is already running, but we want it to be sticky.

45− rtsBool wakeup;

45+ HsBool wakeup;

46#endif

48 // This points to the Capability that the Task "belongs" to. If

@@ -62,14 +62,14 @@ typedef struct Task_ {

62 // The current top-of-stack InCall

63 struct InCall_ *incall;

65− nat n_spare_incalls;

65+ uint32_t n_spare_incalls;

66 struct InCall_ *spare_incalls;

68− rtsBool worker; // == rtsTrue if this is a worker Task

68+ HsBool worker; // == rtsTrue if this is a worker Task

69− rtsBool stopped; // this task has stopped or exited Haskell

69+ HsBool stopped; // this task has stopped or exited Haskell

71 // So that we can detect when a finalizer illegally calls back into Haskell

72− rtsBool running_finalizers;

72+ HsBool running_finalizers;

74 // Links tasks on the returning_tasks queue of a Capability, and

75 // on spare_workers.

@@ -88,7 +88,7 @@ struct Capability_ {

88 StgFunTable f;

89 StgRegTable r;

91− nat no; // capability number.

91+ uint32_t no; // capability number.

93 // The Task currently holding this Capability. This task has

94 // exclusive access to the contents of this Capability (apart from

@@ -98,12 +98,12 @@ struct Capability_ {

99 // true if this Capability is running Haskell code, used for

100 // catching unsafe call-ins.

101− rtsBool in_haskell;

101+ HsBool in_haskell;

102

103 // Has there been any activity on this Capability since the last GC?

104− nat idle;

104+ uint32_t idle;

105

106− rtsBool disabled;

106+ HsBool disabled;

107

108 // The run queue. The Task owning this Capability has exclusive

109 // access to its run queue, so can wake up threads without

@@ -159,7 +159,7 @@ struct Capability_ {

159#if defined(THREADED_RTS)

160 // Worker Tasks waiting in the wings. Singly-linked.

161 Task *spare_workers;

162− nat n_spare_workers; // count of above

162+ uint32_t n_spare_workers; // count of above

163

164 // This lock protects:

165 // running_task

@@ -192,10 +192,9 @@ struct Capability_ {

192

193 // Per-capability STM-related data

194 StgTVarWatchQueue *free_tvar_watch_queues;

195− StgInvariantCheckQueue *free_invariant_check_queues;

196 StgTRecChunk *free_trec_chunks;

195 StgTRecChunk *free_trec_chunks;

197 StgTRecHeader *free_trec_headers;

196 StgTRecHeader *free_trec_headers;

198− nat transaction_tokens;

197+ uint32_t transaction_tokens;

199} // typedef Capability is defined in RtsAPI.h

198} // typedef Capability is defined in RtsAPI.h

200 // We never want a Capability to overlap a cache line with anything

199 // We never want a Capability to overlap a cache line with anything

201 // else, so round it up to a cache line size:

200 // else, so round it up to a cache line size:

bench/Main.hs+7−6

@@ -20,6 +20,7 @@ import qualified Data.Dependent.Map as DMap

20import Data.Dependent.Sum

21import Data.Functor.Misc

22import Data.IORef

23+import Data.Maybe (fromJust)

23import Reflex

24import Reflex

24import Reflex.Host.Class

25import Reflex.Host.Class

@@ -70,7 +71,7 @@ micros =

70 , withSetupWHNF "fireEventsOnly"

71 , withSetupWHNF "fireEventsOnly"

71 (newEventWithTriggerRef >>= subscribePair)

72 (newEventWithTriggerRef >>= subscribePair)

72 (\(_, trigger) -> do

73 (\(_, trigger) -> do

73− Just key <- liftIO $ readIORef trigger

74+ key <- fromJust <$> liftIO (readIORef trigger)

74 fireEvents [key :=> Identity (42 :: Int)])

75 fireEvents [key :=> Identity (42 :: Int)])

75 , withSetupWHNF "fireEventsAndRead(head/merge1)"

76 , withSetupWHNF "fireEventsAndRead(head/merge1)"

76 (setupMerge 1 >>= subscribePair)

77 (setupMerge 1 >>= subscribePair)

@@ -84,14 +85,14 @@ micros =

84 , withSetupWHNF "fireEventsOnly(head/merge100)"

85 , withSetupWHNF "fireEventsOnly(head/merge100)"

85 (setupMerge 100 >>= subscribePair)

86 (setupMerge 100 >>= subscribePair)

86 (\(_, t:_) -> do

87 (\(_, t:_) -> do

87− Just key <- liftIO $ readIORef t

88+ key <- fromJust <$> liftIO (readIORef t)

88 fireEvents [key :=> Identity (42 :: Int)])

89 fireEvents [key :=> Identity (42 :: Int)])

89 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev

90 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev

90 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample

91 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample

91 ]

92 ]

93setupMerge :: Int

94setupMerge :: Int

94− -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)

95+ -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)

95 , [IORef (Maybe (EventTrigger Spider a))]

96 , [IORef (Maybe (EventTrigger Spider a))]

96 )

97 )

97setupMerge num = do

98setupMerge num = do

@@ -99,11 +100,11 @@ setupMerge num = do

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

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

100 pure (merge m, triggers)

101 pure (merge m, triggers)

101

102

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

103+subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b)

103subscribePair (ev, b) = (,b) <$> subscribeEvent ev

104subscribePair (ev, b) = (,b) <$> subscribeEvent ev

104

105

105−fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b

106+fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b

106 -> SpiderHost Global (Maybe b)

107 -> SpiderHost Global (Maybe b)

107fireAndRead trigger val subd = do

108fireAndRead trigger val subd = do

108− Just key <- liftIO $ readIORef trigger

109+ key <- fromJust <$> liftIO (readIORef trigger)

109 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence

110 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence

bench/RunAll.hs+1−1

@@ -136,7 +136,7 @@ benchmarks = implGroup "spider" runSpiderHost cases

136pattern RunTestCaseFlag = "--run-test-case"

137

138spawnBenchmark :: String -> Benchmark

139−spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do

139+spawnBenchmark name = bench name . toBenchmarkable $ \n -> do

140 self <- getExecutablePath

141 callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]

142

default.nix+9−4

@@ -5,13 +5,15 @@

5, semigroupoids, semigroups, split, stdenv, stm, syb

6, template-haskell, these, time, transformers

7, transformers-compat, unbounded-delays, prim-uniq

8−, data-default, filepath, directory, filemanip, generics-sop

9+, data-default, filepath, directory, filemanip, ghcjs-base

10+, monoidal-containers, witherable, generics-sop

9, useTemplateHaskell ? true

11, useTemplateHaskell ? true

10}:

12}:

12mkDerivation {

14mkDerivation {

13 pname = "reflex";

15 pname = "reflex";

14− version = "0.5.0";

16+ version = "0.5.0.1";

15 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

17 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

16 libraryHaskellDepends = [

18 libraryHaskellDepends = [

17 base bifunctors containers dependent-map dependent-sum

19 base bifunctors containers dependent-map dependent-sum

@@ -21,8 +23,11 @@ mkDerivation {

21 transformers-compat prim-uniq

23 transformers-compat prim-uniq

22 base bifunctors containers deepseq dependent-map dependent-sum

24 base bifunctors containers deepseq dependent-map dependent-sum

23 mtl ref-tf split transformers data-default

25 mtl ref-tf split transformers data-default

24− random time unbounded-delays generics-sop

26+ random time unbounded-delays monoidal-containers witherable

27+ generics-sop

28+ ] ++ (if ghc.isGhcjs or false then [

29+ ghcjs-base

25− ] ++ (if !useTemplateHaskell then [] else [

30+ ] else []) ++ (if !useTemplateHaskell then [] else [

26 haskell-src-exts haskell-src-meta

31 haskell-src-exts haskell-src-meta

27 ]);

32 ]);

28 testHaskellDepends = if ghc.isGhcjs or false then [] else [

33 testHaskellDepends = if ghc.isGhcjs or false then [] else [

hydra.jsonnew file+29

@@ -0,0 +1,29 @@

1+{

2+ "enabled": 1,

3+ "hidden": true,

4+ "description": "Jobsets",

5+ "nixexprinput": "src",

6+ "nixexprpath": "jobsets.nix",

7+ "checkinterval": 300,

8+ "schedulingshares": 100,

9+ "enableemail": false,

10+ "emailoverride": "",

11+ "keepnr": 10,

12+ "inputs": {

13+ "src": {

14+ "type": "git",

15+ "value": "https://github.com/reflex-frp/reflex.git develop",

16+ "emailresponsible": false

17+ },

18+ "nixpkgs": {

19+ "type": "git",

20+ "value": "https://github.com/NixOS/nixpkgs-channels nixos-unstable",

21+ "emailresponsible": false

22+ },

23+ "prs": {

24+ "type": "githubpulls",

25+ "value": "reflex-frp reflex",

26+ "emailresponsible": false

27+ }

28+ }

29+}

jobsets.nixnew file+70

@@ -0,0 +1,70 @@

1+{ prs }:

3+let

4+ pkgs = (import ./reflex-platform.nix {}).nixpkgs;

5+ mkFetchGithub = value: {

6+ inherit value;

7+ type = "git";

8+ emailresponsible = false;

9+ };

10+in

11+with pkgs.lib;

12+let

13+ defaults = jobs: {

14+ inherit (jobs) description;

15+ enabled = 1;

16+ hidden = false;

17+ keepnr = 10;

18+ schedulingshares = 100;

19+ checkinterval = 120;

20+ enableemail = false;

21+ emailoverride = "";

22+ nixexprinput = "reflex";

23+ nixexprpath = "release.nix";

24+ inputs = jobs.inputs // {

25+ nixpkgs = {

26+ type = "git";

27+ value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable";

28+ emailresponsible = false;

29+ };

30+ config = {

31+ type = "nix";

32+ value = "{ android_sdk.accept_license = true; }";

33+ emailresponsible = false;

34+ };

35+ };

36+ };

37+ branchJobset = branch: defaults {

38+ description = "reflex-${branch}";

39+ inputs = {

40+ reflex = {

41+ value = "https://github.com/reflex-frp/reflex ${branch}";

42+ type = "git";

43+ emailresponsible = false;

44+ };

45+ };

46+ };

47+ makePr = num: info: {

48+ name = "reflex-pr-${num}";

49+ value = defaults {

50+ description = "#${num}: ${info.title}";

51+ inputs = {

52+ reflex = {

53+ #NOTE: This should really use "pull/${num}/merge"; however, GitHub's

54+ #status checks only operate on PR heads. This creates a race

55+ #condition, which can currently only be solved by requiring PRs to be

56+ #up to date before they're merged. See

57+ #https://github.com/isaacs/github/issues/1002

58+ value = "https://github.com/reflex-frp/reflex pull/${num}/head";

59+ type = "git";

60+ emailresponsible = false;

61+ };

62+ };

63+ };

64+ };

65+ processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs));

66+ jobsetsAttrs = processedPrs //

67+ genAttrs ["develop"] branchJobset;

68+in {

69+ jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs);

70+}

reflex-platform.nixnew file+8

@@ -0,0 +1,8 @@

1+let

2+ reflex-platform-src = (import <nixpkgs> {}).fetchFromGitHub {

3+ owner = "reflex-frp";

4+ repo = "reflex-platform";

5+ rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2";

6+ sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d";

7+ };

8+in import reflex-platform-src

reflex.cabal+105−62

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

1Name: reflex

2−Version: 0.5

2+Version: 0.6

3Synopsis: Higher-order Functional Reactive Programming

4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system

5License: BSD3

@@ -10,13 +10,11 @@ Stability: Experimental

10Category: FRP

11Build-type: Simple

12Cabal-version: >=1.9.2

13−homepage: https://github.com/reflex-frp/reflex

13+homepage: https://reflex-frp.org

14bug-reports: https://github.com/reflex-frp/reflex/issues

15−

15+extra-source-files:

16−flag specialize-to-spidertimeline-global

16+ README.md

17− description: Specialize all Reflex functions to the SpiderTimeline Global implementation. This may improve performance, but will disable all other implementations.

17+ Quickref.md

18− default: False

19− manual: True

21flag use-reflex-optimizer

19flag use-reflex-optimizer

22 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.

20 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.

@@ -28,21 +26,11 @@ flag use-template-haskell

28 default: True

26 default: True

29 manual: True

27 manual: True

31−flag expose-all-unfoldings

32− description: Build the library with -fexpose-all-unfoldings which can help client code specialize better

33− default: False

34− manual: True

35−

36flag debug-trace-events

29flag debug-trace-events

37 description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!

30 description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!

38 default: False

31 default: False

39 manual: True

32 manual: True

41−flag experimental-dependent-sum-instances

42− description: Use experimental incoherent instances for certain forked dependent-sum typeclasses

43− default: False

44− manual: True

45−

46flag fast-weak

34flag fast-weak

47 description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default

35 description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default

48 default: False

36 default: False

@@ -52,16 +40,17 @@ library

52 hs-source-dirs: src

40 hs-source-dirs: src

53 build-depends:

41 build-depends:

54 MemoTrie == 0.6.*,

42 MemoTrie == 0.6.*,

55− base >= 4.7 && < 4.11,

43+ base >= 4.9 && < 4.13,

56− bifunctors >= 5.2 && < 5.5,

44+ bifunctors >= 5.2 && < 5.6,

57 comonad,

45 comonad,

58− containers == 0.5.*,

46+ containers >= 0.5 && < 0.7,

59 data-default >= 0.5 && < 0.8,

47 data-default >= 0.5 && < 0.8,

60 dependent-map >= 0.2.4 && < 0.3,

48 dependent-map >= 0.2.4 && < 0.3,

61 exception-transformers == 0.4.*,

49 exception-transformers == 0.4.*,

62 generics-sop >= 0.2.4.0,

50 generics-sop >= 0.2.4.0,

63 lens >= 4.7 && < 5,

51 lens >= 4.7 && < 5,

64 monad-control >= 1.0.1 && < 1.1,

52 monad-control >= 1.0.1 && < 1.1,

53+ monoidal-containers == 0.4.*,

65 mtl >= 2.1 && < 2.3,

54 mtl >= 2.1 && < 2.3,

66 prim-uniq >= 0.1.0.1 && < 0.2,

55 prim-uniq >= 0.1.0.1 && < 0.2,

67 primitive >= 0.5 && < 0.7,

56 primitive >= 0.5 && < 0.7,

@@ -70,31 +59,39 @@ library

70 reflection == 2.1.*,

59 reflection == 2.1.*,

71 semigroupoids >= 4.0 && < 6,

60 semigroupoids >= 4.0 && < 6,

72 semigroups >= 0.16 && < 0.19,

61 semigroups >= 0.16 && < 0.19,

73− stm == 2.4.*,

62+ stm >= 2.4 && < 2.6,

74 syb >= 0.5 && < 0.8,

63 syb >= 0.5 && < 0.8,

75− these >= 0.4 && < 0.8,

64+ these >= 0.4 && < 0.7.7,

76 time >= 1.4 && < 1.9,

65 time >= 1.4 && < 1.9,

77 transformers >= 0.2,

66 transformers >= 0.2,

78 transformers-compat >= 0.3,

67 transformers-compat >= 0.3,

79− unbounded-delays >= 0.1.0.0 && < 0.2

68+ unbounded-delays >= 0.1.0.0 && < 0.2,

69+ witherable >= 0.2 && < 0.4

81 exposed-modules:

71 exposed-modules:

82 Data.AppendMap,

72 Data.AppendMap,

83− Data.Map.Misc,

73+ Data.FastMutableIntMap,

74+ Data.FastWeakBag,

84 Data.Functor.Misc,

75 Data.Functor.Misc,

76+ Data.Map.Misc,

85 Data.WeakBag,

77 Data.WeakBag,

86− Data.FastWeakBag,

87− Data.FastMutableIntMap,

88 Generics.SOP.DMapUtilities,

78 Generics.SOP.DMapUtilities,

89 Generics.SOP.Distribute,

79 Generics.SOP.Distribute,

90 Reflex,

80 Reflex,

91 Reflex.Class,

81 Reflex.Class,

82+ Reflex.Adjustable.Class,

83+ Reflex.BehaviorWriter.Base,

84+ Reflex.BehaviorWriter.Class,

92 Reflex.Collection,

85 Reflex.Collection,

93− Reflex.EventWriter,

94 Reflex.Dynamic,

86 Reflex.Dynamic,

95 Reflex.Dynamic.Uniq,

87 Reflex.Dynamic.Uniq,

96 Reflex.Dynamic.CollectDynGeneric,

88 Reflex.Dynamic.CollectDynGeneric,

97 Reflex.DynamicWriter,

89 Reflex.DynamicWriter,

90+ Reflex.DynamicWriter.Base,

91+ Reflex.DynamicWriter.Class,

92+ Reflex.EventWriter,

93+ Reflex.EventWriter.Base,

94+ Reflex.EventWriter.Class,

98 Reflex.FastWeak,

95 Reflex.FastWeak,

99 Reflex.FunctorMaybe,

96 Reflex.FunctorMaybe,

100 Reflex.Host.Class,

97 Reflex.Host.Class,

@@ -107,13 +104,12 @@ library

107 Reflex.Patch.IntMap,

104 Reflex.Patch.IntMap,

108 Reflex.Patch.Map,

105 Reflex.Patch.Map,

109 Reflex.Patch.MapWithMove,

106 Reflex.Patch.MapWithMove,

110− Reflex.TriggerEvent.Base,

111− Reflex.TriggerEvent.Class,

112 Reflex.PerformEvent.Base,

107 Reflex.PerformEvent.Base,

113 Reflex.PerformEvent.Class,

108 Reflex.PerformEvent.Class,

114 Reflex.PostBuild.Base,

109 Reflex.PostBuild.Base,

115 Reflex.PostBuild.Class,

110 Reflex.PostBuild.Class,

116 Reflex.Profiled,

111 Reflex.Profiled,

112+ Reflex.Pure,

117 Reflex.Query.Base,

113 Reflex.Query.Base,

118 Reflex.Query.Class,

114 Reflex.Query.Class,

119 Reflex.Requester.Base,

115 Reflex.Requester.Base,

@@ -121,16 +117,12 @@ library

121 Reflex.Spider,

117 Reflex.Spider,

122 Reflex.Spider.Internal,

118 Reflex.Spider.Internal,

123 Reflex.Time,

119 Reflex.Time,

120+ Reflex.TriggerEvent.Base,

121+ Reflex.TriggerEvent.Class,

124 Reflex.Widget.Basic,

122 Reflex.Widget.Basic,

125 Reflex.Workflow

123 Reflex.Workflow

126

124

127− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively

125+ ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively

128− ghc-prof-options: -fprof-auto

129−

130− if flag(specialize-to-spidertimeline-global)

131− cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

132− else

133− exposed-modules: Reflex.Pure

134

126

135 if flag(debug-trace-events)

127 if flag(debug-trace-events)

136 cpp-options: -DDEBUG_TRACE_EVENTS

128 cpp-options: -DDEBUG_TRACE_EVENTS

@@ -145,9 +137,9 @@ library

145 cpp-options: -DUSE_TEMPLATE_HASKELL

137 cpp-options: -DUSE_TEMPLATE_HASKELL

146 build-depends:

138 build-depends:

147 dependent-sum >= 0.3 && < 0.5,

139 dependent-sum >= 0.3 && < 0.5,

148− haskell-src-exts >= 1.16 && < 1.20,

140+ haskell-src-exts >= 1.16 && < 1.21,

149 haskell-src-meta >= 0.6 && < 0.9,

141 haskell-src-meta >= 0.6 && < 0.9,

150− template-haskell >= 2.9 && < 2.13

142+ template-haskell >= 2.9 && < 2.15

151 exposed-modules:

143 exposed-modules:

152 Reflex.Dynamic.TH

144 Reflex.Dynamic.TH

153 other-extensions: TemplateHaskell

145 other-extensions: TemplateHaskell

@@ -155,14 +147,8 @@ library

155 build-depends:

147 build-depends:

156 dependent-sum == 0.4.*

148 dependent-sum == 0.4.*

157

149

158− if flag(expose-all-unfoldings)

159− ghc-options: -fexpose-all-unfoldings

160−

161− if flag(experimental-dependent-sum-instances)

162− ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES

163−

164 if flag(fast-weak) && impl(ghcjs)

150 if flag(fast-weak) && impl(ghcjs)

165− ghc-options: -DGHCJS_FAST_WEAK

151+ cpp-options: -DGHCJS_FAST_WEAK

166

152

167 if impl(ghcjs)

153 if impl(ghcjs)

168 build-depends: ghcjs-base

154 build-depends: ghcjs-base

@@ -186,23 +172,34 @@ test-suite semantics

186 reflex,

172 reflex,

187 split,

173 split,

188 transformers >= 0.3

174 transformers >= 0.3

189− if flag(specialize-to-spidertimeline-global)

175+ other-modules:

190− buildable: False

176+ Reflex.Bench.Focused

177+ Reflex.Plan.Pure

178+ Reflex.Plan.Reflex

179+ Reflex.Test

180+ Reflex.Test.Micro

181+ Reflex.TestPlan

191

182

192test-suite CrossImpl

183test-suite CrossImpl

193 type: exitcode-stdio-1.0

184 type: exitcode-stdio-1.0

194 main-is: Reflex/Test/CrossImpl.hs

185 main-is: Reflex/Test/CrossImpl.hs

195 hs-source-dirs: test

186 hs-source-dirs: test

196− ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test

187+ ghc-options: -O2 -Wall -rtsopts

197 build-depends:

188 build-depends:

198 base,

189 base,

199 containers,

190 containers,

200 dependent-map,

191 dependent-map,

192+ dependent-sum,

193+ deepseq >= 1.3 && < 1.5,

201 mtl,

194 mtl,

195+ transformers,

202 ref-tf,

196 ref-tf,

203 reflex

197 reflex

204− if flag(specialize-to-spidertimeline-global)

198+ other-modules:

205− buildable: False

199+ Reflex.Test

200+ Reflex.TestPlan

201+ Reflex.Plan.Reflex

202+ Reflex.Plan.Pure

206

203

207test-suite hlint

204test-suite hlint

208 type: exitcode-stdio-1.0

205 type: exitcode-stdio-1.0

@@ -215,19 +212,28 @@ test-suite hlint

215 , hlint

212 , hlint

216 if impl(ghcjs)

213 if impl(ghcjs)

217 buildable: False

214 buildable: False

218− buildable: False

219

215

220test-suite EventWriterT

216test-suite EventWriterT

221 type: exitcode-stdio-1.0

217 type: exitcode-stdio-1.0

222 main-is: EventWriterT.hs

218 main-is: EventWriterT.hs

223 hs-source-dirs: test

219 hs-source-dirs: test

224 build-depends: base

220 build-depends: base

221+ , containers

222+ , deepseq >= 1.3 && < 1.5

223+ , dependent-map

225 , dependent-sum

224 , dependent-sum

226 , lens

225 , lens

226+ , mtl

227 , these

228 , transformers

229 , reflex

230 , ref-tf

231+ other-modules:

232+ Reflex.Test

233+ Reflex.TestPlan

234+ Reflex.Plan.Reflex

235+ Reflex.Plan.Pure

236+ Test.Run

231

237

232test-suite RequesterT

238test-suite RequesterT

233 type: exitcode-stdio-1.0

239 type: exitcode-stdio-1.0

@@ -242,6 +248,9 @@ test-suite RequesterT

242 , reflex

248 , reflex

243 , ref-tf

249 , ref-tf

244 buildable: False

250 buildable: False

251+ other-modules:

252+ Reflex.TestPlan

253+ Reflex.Plan.Pure

245

254

246test-suite QueryT

255test-suite QueryT

247 type: exitcode-stdio-1.0

256 type: exitcode-stdio-1.0

@@ -249,37 +258,61 @@ test-suite QueryT

249 hs-source-dirs: test

258 hs-source-dirs: test

250 build-depends: base

259 build-depends: base

251 , containers

260 , containers

252− , dependent-sum

253 , dependent-map

261 , dependent-map

262+ , dependent-sum

263+ , deepseq >= 1.3 && < 1.5

254 , lens

264 , lens

265+ , monoidal-containers

266+ , mtl

267+ , ref-tf

268+ , reflex

269+ , semigroups

255 , these

270 , these

256 , transformers

271 , transformers

257− , semigroups

272+ other-modules:

258− , reflex

273+ Test.Run

259− , ref-tf

274+ Reflex.TestPlan

275+ Reflex.Plan.Reflex

276+ Reflex.Plan.Pure

260

277

261test-suite GC-Semantics

278test-suite GC-Semantics

262 type: exitcode-stdio-1.0

279 type: exitcode-stdio-1.0

263 main-is: GC.hs

280 main-is: GC.hs

264 hs-source-dirs: test

281 hs-source-dirs: test

265− if flag(specialize-to-spidertimeline-global)

266− buildable: False

267 build-depends: base

282 build-depends: base

283+ , containers

268 , dependent-sum

284 , dependent-sum

269 , dependent-map

285 , dependent-map

286+ , deepseq >= 1.3 && < 1.5

287+ , mtl

270 , these

288 , these

271 , transformers

289 , transformers

272 , reflex

290 , reflex

273 , ref-tf

291 , ref-tf

274 if impl(ghc < 8)

292 if impl(ghc < 8)

275 build-depends: semigroups

293 build-depends: semigroups

294+ other-modules:

295+ Reflex.Plan.Pure

296+ Reflex.Plan.Reflex

297+ Reflex.TestPlan

298+ Test.Run

276

299

277test-suite rootCleanup

300test-suite rootCleanup

278 type: exitcode-stdio-1.0

301 type: exitcode-stdio-1.0

279 main-is: rootCleanup.hs

302 main-is: rootCleanup.hs

280 hs-source-dirs: test

303 hs-source-dirs: test

281 build-depends: base

304 build-depends: base

305+ , containers

306+ , deepseq >= 1.3 && < 1.5

307+ , dependent-sum

308+ , mtl

282 , reflex

309 , reflex

310+ , ref-tf

311+ , these

312+ other-modules:

313+ Reflex.Plan.Pure

314+ Reflex.TestPlan

315+ Test.Run

283

316

284test-suite mkDyn

317test-suite mkDyn

285 type: exitcode-stdio-1.0

318 type: exitcode-stdio-1.0

@@ -295,20 +328,27 @@ test-suite mkDyn

295

328

296benchmark spider-bench

329benchmark spider-bench

297 type: exitcode-stdio-1.0

330 type: exitcode-stdio-1.0

298− hs-source-dirs: bench

331+ hs-source-dirs: bench test

299 main-is: Main.hs

332 main-is: Main.hs

300 ghc-options: -Wall -O2 -rtsopts

333 ghc-options: -Wall -O2 -rtsopts

301 build-depends:

334 build-depends:

302 base,

335 base,

336+ containers,

303− criterion == 1.1.*,

337+ criterion >= 1.1 && < 1.6,

304 deepseq >= 1.3 && < 1.5,

338 deepseq >= 1.3 && < 1.5,

305 dependent-map,

339 dependent-map,

306 dependent-sum,

340 dependent-sum,

341+ ref-tf,

307 mtl,

342 mtl,

308 primitive,

343 primitive,

309 reflex,

344 reflex,

345+ split,

310 stm,

346 stm,

311 transformers >= 0.3

347 transformers >= 0.3

348+ other-modules:

349+ Reflex.TestPlan

350+ Reflex.Plan.Reflex

351+ Reflex.Bench.Focused

312

352

313benchmark saulzar-bench

353benchmark saulzar-bench

314 type: exitcode-stdio-1.0

354 type: exitcode-stdio-1.0

@@ -316,11 +356,10 @@ benchmark saulzar-bench

316 c-sources: bench-cbits/checkCapability.c

356 c-sources: bench-cbits/checkCapability.c

317 main-is: RunAll.hs

357 main-is: RunAll.hs

318 ghc-options: -Wall -O2 -rtsopts -threaded

358 ghc-options: -Wall -O2 -rtsopts -threaded

319− ghc-prof-options: -fprof-auto

320 build-depends:

359 build-depends:

321 base,

360 base,

322− containers == 0.5.*,

361+ containers >= 0.5 && < 0.7,

323− criterion == 1.1.*,

362+ criterion >= 1.1 && < 1.6,

324 deepseq >= 1.3 && < 1.5,

363 deepseq >= 1.3 && < 1.5,

325 dependent-map,

364 dependent-map,

326 dependent-sum,

365 dependent-sum,

@@ -334,6 +373,10 @@ benchmark saulzar-bench

334 stm,

373 stm,

335 time,

374 time,

336 transformers >= 0.3

375 transformers >= 0.3

376+ other-modules:

377+ Reflex.TestPlan

378+ Reflex.Plan.Reflex

379+ Reflex.Bench.Focused

337

380

338source-repository head

381source-repository head

339 type: git

382 type: git

release.nixnew file+9

@@ -0,0 +1,9 @@

1+{ rp ? import ./reflex-platform.nix {}

2+}:

3+let

4+ inherit (rp.nixpkgs) lib;

5+ compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"];

6+in lib.genAttrs compilers (ghc: {

7+ reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; };

8+ reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; };

9+})

src/Data/AppendMap.hs+36−373

@@ -1,408 +1,71 @@

1−{-# LANGUAGE DeriveFunctor #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DeriveTraversable #-}

4{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE PatternSynonyms #-}

8{-# LANGUAGE RoleAnnotations #-}

6{-# LANGUAGE RoleAnnotations #-}

9{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

9+{-# OPTIONS_GHC -fno-warn-orphans #-}

11-- | 'Data.Map' with a better 'Monoid' instance

10-- | 'Data.Map' with a better 'Monoid' instance

12--

11--

13-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has

12-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has

14-- @mappend = unionWith mappend@ instead.

13-- @mappend = unionWith mappend@ instead.

15−module Data.AppendMap where

14+module Data.AppendMap

15+ ( module Data.AppendMap

16+ , module Data.Map.Monoidal

17+ ) where

17−import Prelude hiding (map)

19+import Prelude hiding (map, null)

19−import Control.Lens

20−import Data.Align

21import Data.Coerce

22import Data.Default

23import Data.Map (Map)

24+#if MIN_VERSION_containers(0,5,11)

24−import qualified Data.Map as Map

25+import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)

25−import Data.Semigroup

26+#else

26−import Data.Set (Set)

27+import qualified Data.Map as Map (showTree, showTreeWith)

28+#endif

27−import Data.Typeable

29+import Data.Witherable (Filterable(..))

28−import GHC.Generics (Generic)

30+import Data.Map.Monoidal (MonoidalMap(..), delete, null, empty)

29−import Reflex.Class (FunctorMaybe (..))

31+import qualified Data.Map.Monoidal as M

30−import Reflex.Patch (Additive, Group (..))

32−newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }

33+{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}

33− deriving (Eq, Ord, Show, Read, Typeable, Generic, Functor, Foldable, Traversable, Align)

34+type AppendMap = MonoidalMap

35−type instance (Index (AppendMap k m)) = k

36+{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}

36−type instance (IxValue (AppendMap k m)) = m

37+_unAppendMap :: MonoidalMap k v -> Map k v

38+_unAppendMap = getMonoidalMap

38−instance Ord k => Ixed (AppendMap k m) where

40+pattern AppendMap :: Map k v -> MonoidalMap k v

39− ix i = _Wrapped . ix i

41+pattern AppendMap m = MonoidalMap m

41−instance Ord k => At (AppendMap k m) where

43+instance Filterable (MonoidalMap k) where

42− at i = _Wrapped . at i

43−

44−instance FunctorMaybe (AppendMap k) where

45− fmapMaybe = mapMaybe

44+ mapMaybe = M.mapMaybe

47-- | Deletes a key, returning 'Nothing' if the result is empty.

46-- | Deletes a key, returning 'Nothing' if the result is empty.

48−nonEmptyDelete :: Ord k => k -> AppendMap k a -> Maybe (AppendMap k a)

47+nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)

49nonEmptyDelete k vs =

48nonEmptyDelete k vs =

50 let deleted = delete k vs

49 let deleted = delete k vs

51− in if Data.AppendMap.null deleted

50+ in if null deleted

52 then Nothing

51 then Nothing

53 else Just deleted

52 else Just deleted

55mapMaybeNoNull :: (a -> Maybe b)

54mapMaybeNoNull :: (a -> Maybe b)

56− -> AppendMap token a

55+ -> MonoidalMap token a

57− -> Maybe (AppendMap token b)

56+ -> Maybe (MonoidalMap token b)

58mapMaybeNoNull f as =

57mapMaybeNoNull f as =

59− let bs = fmapMaybe f as

58+ let bs = mapMaybe f as

60− in if Data.AppendMap.null bs

59+ in if null bs

61 then Nothing

60 then Nothing

62 else Just bs

61 else Just bs

64−instance FunctorWithIndex k (AppendMap k) where

63+-- TODO: Move instances to `Reflex.Patch`

65− imap f = AppendMap . imap f . _unAppendMap

64+showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String

66− imapped = _Wrapped . imapped

65+showTree = coerce (Map.showTree :: Map k a -> String)

67−

68−instance FoldableWithIndex k (AppendMap k) where

69− ifolded = _Wrapped . ifolded

70−

71−instance TraversableWithIndex k (AppendMap k) where

72− itraverse = itraverseOf itraversed

73− itraversed = _Wrapped . itraversed

74−

75−instance (Ord k, Semigroup m) => Semigroup (AppendMap k m) where

76− (AppendMap m0) <> (AppendMap m1) = AppendMap $ Map.unionWith (<>) m0 m1

77−

78−instance (Ord k, Semigroup m) => Monoid (AppendMap k m) where

79− mempty = empty

80− mappend = (<>)

81−

82−instance (Ord k, Group q) => Group (AppendMap k q) where

83− negateG = map negateG

84−

85−instance (Ord k, Additive q) => Additive (AppendMap k q)

86−

87−(!) :: forall k a. Ord k => AppendMap k a -> k -> a

88−(!) = coerce ((Map.!) :: Map k a -> k -> a)

89−infixl 9 !

90−

91−(\\) :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a

92−(\\) = coerce ((Map.\\) :: Map k a -> Map k b -> Map k a)

93−infixl 9 \\

94−

95−null :: forall k a. AppendMap k a -> Bool

96−null = coerce (Map.null :: Map k a -> Bool)

97−

98−size :: forall k a. AppendMap k a -> Int

99−size = coerce (Map.size :: Map k a -> Int)

100−

101−member :: forall k a. Ord k => k -> AppendMap k a -> Bool

102−member = coerce (Map.member :: k -> Map k a -> Bool)

103−

104−notMember :: forall k a. Ord k => k -> AppendMap k a -> Bool

105−notMember = coerce (Map.notMember :: k -> Map k a -> Bool)

106−

107−lookup :: forall k a. Ord k => k -> AppendMap k a -> Maybe a

108−lookup = coerce (Map.lookup :: k -> Map k a -> Maybe a)

109−

110−findWithDefault :: forall k a. Ord k => a -> k -> AppendMap k a -> a

111−findWithDefault = coerce (Map.findWithDefault :: a -> k -> Map k a -> a)

112−

113−lookupLT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

114−lookupLT = coerce (Map.lookupLT :: k -> Map k a -> Maybe (k,a))

115−

116−lookupGT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

117−lookupGT = coerce (Map.lookupGT :: k -> Map k a -> Maybe (k,a))

118−

119−lookupLE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

120−lookupLE = coerce (Map.lookupLE :: k -> Map k a -> Maybe (k,a))

121−

122−lookupGE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

123−lookupGE = coerce (Map.lookupGE :: k -> Map k a -> Maybe (k,a))

124−

125−empty :: forall k a. AppendMap k a

126−empty = coerce (Map.empty :: Map k a)

127−

128−singleton :: forall k a. k -> a -> AppendMap k a

129−singleton = coerce (Map.singleton :: k -> a -> Map k a)

130−

131−insert :: forall k a. Ord k => k -> a -> AppendMap k a -> AppendMap k a

132−insert = coerce (Map.insert :: k -> a -> Map k a -> Map k a)

133−

134−insertWith :: forall k a. Ord k => (a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a

135−insertWith = coerce (Map.insertWith :: (a -> a -> a) -> k -> a -> Map k a -> Map k a)

136−

137−insertWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a

138−insertWithKey = coerce (Map.insertWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a)

139−

140−insertLookupWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> (Maybe a, AppendMap k a)

141−insertLookupWithKey = coerce (Map.insertLookupWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a))

142−

143−delete :: forall k a. Ord k => k -> AppendMap k a -> AppendMap k a

144−delete = coerce (Map.delete :: k -> Map k a -> Map k a)

145−

146−adjust :: forall k a. Ord k => (a -> a) -> k -> AppendMap k a -> AppendMap k a

147−adjust = coerce (Map.adjust :: (a -> a) -> k -> Map k a -> Map k a)

148−

149−adjustWithKey :: forall k a. Ord k => (k -> a -> a) -> k -> AppendMap k a -> AppendMap k a

150−adjustWithKey = coerce (Map.adjustWithKey :: (k -> a -> a) -> k -> Map k a -> Map k a)

151−

152−update :: forall k a. Ord k => (a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a

153−update = coerce (Map.update :: (a -> Maybe a) -> k -> Map k a -> Map k a)

154−

155−updateWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a

156−updateWithKey = coerce (Map.updateWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> Map k a)

157−

158−updateLookupWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> (Maybe a, AppendMap k a)

159−updateLookupWithKey = coerce (Map.updateLookupWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a))

160−

161−alter :: forall k a. Ord k => (Maybe a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a

162−alter = coerce (Map.alter :: (Maybe a -> Maybe a) -> k -> Map k a -> Map k a)

163−

164−unionWith :: forall k a. Ord k => (a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a

165−unionWith = coerce (Map.unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a)

166−

167−unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a

168−unionWithKey = coerce (Map.unionWithKey :: (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a)

169−

170−unionsWith :: forall k a. Ord k => (a -> a -> a) -> [AppendMap k a] -> AppendMap k a

171−unionsWith = coerce (Map.unionsWith :: (a -> a -> a) -> [Map k a] -> Map k a)

172−

173−difference :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a

174−difference = (\\)

175−

176−differenceWith :: forall k a b. Ord k => (a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a

177−differenceWith = coerce (Map.differenceWith :: (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)

178−

179−differenceWithKey :: forall k a b. Ord k => (k -> a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a

180−differenceWithKey = coerce (Map.differenceWithKey :: (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)

181−

182−intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c

183−intersectionWith = coerce (Map.intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c)

184−

185−intersectionWithKey :: forall k a b c. Ord k => (k -> a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c

186−intersectionWithKey = coerce (Map.intersectionWithKey :: (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c)

187−

188−mergeWithKey :: forall k a b c. Ord k => (k -> a -> b -> Maybe c) -> (AppendMap k a -> AppendMap k c) -> (AppendMap k b -> AppendMap k c) -> AppendMap k a -> AppendMap k b -> AppendMap k c

189−mergeWithKey = coerce (Map.mergeWithKey :: (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c)

190−

191−map :: (a -> b) -> AppendMap k a -> AppendMap k b

192−map = fmap

193−

194−mapWithKey :: (k -> a -> b) -> AppendMap k a -> AppendMap k b

195−mapWithKey = imap

196−

197−traverseWithKey :: Applicative t => (k -> a -> t b) -> AppendMap k a -> t (AppendMap k b)

198−traverseWithKey = itraverse

199−

200−mapAccum :: forall k a b c. (a -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)

201−mapAccum = coerce (Map.mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))

202−

203−mapAccumWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)

204−mapAccumWithKey = coerce (Map.mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))

205−

206−mapAccumRWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)

207−mapAccumRWithKey = coerce (Map.mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))

208−

209−mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a

210−mapKeys = coerce (Map.mapKeys :: (k1 -> k2) -> Map k1 a -> Map k2 a)

211−

212−mapKeysWith :: forall k1 k2 a. Ord k2 => (a -> a -> a) -> (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a

213−mapKeysWith = coerce (Map.mapKeysWith :: (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a)

214−

215−mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a

216−mapKeysMonotonic = coerce (Map.mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a)

217−

218−foldr :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b

219−foldr = coerce (Map.foldr :: (a -> b -> b) -> b -> Map k a -> b)

220−

221−foldl :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a

222−foldl = coerce (Map.foldl :: (a -> b -> a) -> a -> Map k b -> a)

223−

224−foldrWithKey :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b

225−foldrWithKey = coerce (Map.foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b)

226−

227−foldlWithKey :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a

228−foldlWithKey = coerce (Map.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a)

229−

230−foldMapWithKey :: forall k a m. Monoid m => (k -> a -> m) -> AppendMap k a -> m

231−foldMapWithKey = coerce (Map.foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m)

232−

233−foldr' :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b

234−foldr' = coerce (Map.foldr' :: (a -> b -> b) -> b -> Map k a -> b)

235

236−foldl' :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a

237−foldl' = coerce (Map.foldl' :: (a -> b -> a) -> a -> Map k b -> a)

238−

239−foldrWithKey' :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b

240−foldrWithKey' = coerce (Map.foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b)

241−

242−foldlWithKey' :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a

243−foldlWithKey' = coerce (Map.foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a)

244−

245−elems :: forall k a. AppendMap k a -> [a]

246−elems = coerce (Map.elems :: Map k a -> [a])

247−

248−keys :: forall k a. AppendMap k a -> [k]

249−keys = coerce (Map.keys :: Map k a -> [k])

250−

251−assocs :: forall k a. AppendMap k a -> [(k, a)]

252−assocs = coerce (Map.assocs :: Map k a -> [(k, a)])

253−

254−keysSet :: forall k a. AppendMap k a -> Set k

255−keysSet = coerce (Map.keysSet :: Map k a -> Set k)

256−

257−fromSet :: forall k a. (k -> a) -> Set k -> AppendMap k a

258−fromSet = coerce (Map.fromSet :: (k -> a) -> Set k -> Map k a)

259−

260−toList :: forall k a. AppendMap k a -> [(k, a)]

261−toList = coerce (Map.toList :: Map k a -> [(k, a)])

262−

263−fromList :: forall k a. Ord k => [(k, a)] -> AppendMap k a

264−fromList = coerce (Map.fromList :: [(k, a)] -> Map k a)

265−

266−fromListWith :: forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> AppendMap k a

267−fromListWith = coerce (Map.fromListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)

268−

269−fromListWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a

270−fromListWithKey = coerce (Map.fromListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)

271−

272−toAscList :: forall k a. AppendMap k a -> [(k, a)]

273−toAscList = coerce (Map.toAscList :: Map k a -> [(k, a)])

274−

275−toDescList :: forall k a. AppendMap k a -> [(k, a)]

276−toDescList = coerce (Map.toDescList :: Map k a -> [(k, a)])

277−

278−fromAscList :: forall k a. Eq k => [(k, a)] -> AppendMap k a

279−fromAscList = coerce (Map.fromAscList :: [(k, a)] -> Map k a)

280−

281−fromAscListWith :: forall k a. Eq k => (a -> a -> a) -> [(k, a)] -> AppendMap k a

282−fromAscListWith = coerce (Map.fromAscListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)

283−

284−fromAscListWithKey :: forall k a. Eq k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a

285−fromAscListWithKey = coerce (Map.fromAscListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)

286−

287−fromDistinctAscList :: forall k a. [(k, a)] -> AppendMap k a

288−fromDistinctAscList = coerce (Map.fromDistinctAscList :: [(k, a)] -> Map k a)

289−

290−filter :: forall k a. (a -> Bool) -> AppendMap k a -> AppendMap k a

291−filter = coerce (Map.filter :: (a -> Bool) -> Map k a -> Map k a)

292−

293−filterWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> AppendMap k a

294−filterWithKey = coerce (Map.filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a)

295−

296−partition :: forall k a. (a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)

297−partition = coerce (Map.partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a))

298−

299−partitionWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)

300−partitionWithKey = coerce (Map.partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a))

301−

302−mapMaybe :: forall k a b. (a -> Maybe b) -> AppendMap k a -> AppendMap k b

303−mapMaybe = coerce (Map.mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b)

304−

305−mapMaybeWithKey :: forall k a b. (k -> a -> Maybe b) -> AppendMap k a -> AppendMap k b

306−mapMaybeWithKey = coerce (Map.mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b)

307−

308−mapEither :: forall k a b c. (a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)

309−mapEither = coerce (Map.mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c))

310−

311−mapEitherWithKey :: forall k a b c. (k -> a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)

312−mapEitherWithKey = coerce (Map.mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c))

313−

314−split :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, AppendMap k a)

315−split = coerce (Map.split :: k -> Map k a -> (Map k a, Map k a))

316−

317−splitLookup :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, Maybe a, AppendMap k a)

318−splitLookup = coerce (Map.splitLookup :: k -> Map k a -> (Map k a, Maybe a, Map k a))

319−

320−splitRoot :: forall k a. AppendMap k a -> [AppendMap k a]

321−splitRoot = coerce (Map.splitRoot :: Map k a -> [Map k a])

322−

323−isSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool

324−isSubmapOf = coerce (Map.isSubmapOf :: Map k a -> Map k a -> Bool)

325−

326−isSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool

327−isSubmapOfBy = coerce (Map.isSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)

328−

329−isProperSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool

330−isProperSubmapOf = coerce (Map.isProperSubmapOf :: Map k a -> Map k a -> Bool)

331−

332−isProperSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool

333−isProperSubmapOfBy = coerce (Map.isProperSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)

334−

335−lookupIndex :: forall k a. Ord k => k -> AppendMap k a -> Maybe Int

336−lookupIndex = coerce (Map.lookupIndex :: k -> Map k a -> Maybe Int)

337−

338−findIndex :: forall k a. Ord k => k -> AppendMap k a -> Int

339−findIndex = coerce (Map.findIndex :: k -> Map k a -> Int)

340−

341−elemAt :: forall k a. Int -> AppendMap k a -> (k, a)

342−elemAt = coerce (Map.elemAt :: Int -> Map k a -> (k, a))

343−

344−updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> AppendMap k a -> AppendMap k a

345−updateAt = coerce (Map.updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a)

346−

347−deleteAt :: forall k a. Int -> AppendMap k a -> AppendMap k a

348−deleteAt = coerce (Map.deleteAt :: Int -> Map k a -> Map k a)

349−

350−findMin :: forall k a. AppendMap k a -> (k, a)

351−findMin = coerce (Map.findMin :: Map k a -> (k, a))

352−

353−findMax :: forall k a. AppendMap k a -> (k, a)

354−findMax = coerce (Map.findMax :: Map k a -> (k, a))

355−

356−deleteMin :: forall k a. AppendMap k a -> AppendMap k a

357−deleteMin = coerce (Map.deleteMin :: Map k a -> Map k a)

358−

359−deleteMax :: forall k a. AppendMap k a -> AppendMap k a

360−deleteMax = coerce (Map.deleteMax :: Map k a -> Map k a)

361−

362−deleteFindMin :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)

363−deleteFindMin = coerce (Map.deleteFindMin :: Map k a -> ((k, a), Map k a))

364−

365−deleteFindMax :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)

366−deleteFindMax = coerce (Map.deleteFindMax :: Map k a -> ((k, a), Map k a))

367−

368−updateMin :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a

369−updateMin = coerce (Map.updateMin :: (a -> Maybe a) -> Map k a -> Map k a)

370−

371−updateMax :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a

372−updateMax = coerce (Map.updateMax :: (a -> Maybe a) -> Map k a -> Map k a)

373−

374−updateMinWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a

375−updateMinWithKey = coerce (Map.updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)

376−

377−updateMaxWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a

378−updateMaxWithKey = coerce (Map.updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)

379−

380−minView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)

381−minView = coerce (Map.minView :: Map k a -> Maybe (a, Map k a))

382−

383−maxView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)

384−maxView = coerce (Map.maxView :: Map k a -> Maybe (a, Map k a))

385−

386−minViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)

387−minViewWithKey = coerce (Map.minViewWithKey :: Map k a -> Maybe ((k, a), Map k a))

388−

389−maxViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)

390−maxViewWithKey = coerce (Map.maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a))

391−

392−showTree :: forall k a. (Show k, Show a) => AppendMap k a -> String

393−showTree = coerce (Map.showTree :: (Show k, Show a) => Map k a -> String)

394−

395−showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> AppendMap k a -> String

67+showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String

396showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)

68showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)

397

398−valid :: forall k a. Ord k => AppendMap k a -> Bool

399−valid = coerce (Map.valid :: Ord k => Map k a -> Bool)

400−

401−instance Default (AppendMap k a) where

70+instance Default (MonoidalMap k a) where

402 def = empty

71 def = empty

403−

404−instance AppendMap k' v' ~ t => Rewrapped (AppendMap k a) t

405−

406−instance Wrapped (AppendMap k a) where

407− type Unwrapped (AppendMap k a) = Map k a

408− _Wrapped' = iso (\(AppendMap m) -> m) AppendMap

src/Data/FastMutableIntMap.hs+3−7

@@ -1,7 +1,3 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE DeriveFoldable #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE TypeFamilies #-}

1{-# LANGUAGE TypeFamilies #-}

6module Data.FastMutableIntMap

2module Data.FastMutableIntMap

7 ( FastMutableIntMap

3 ( FastMutableIntMap

@@ -26,13 +22,13 @@ module Data.FastMutableIntMap

26--TODO: Fast copy to FastIntMap

22--TODO: Fast copy to FastIntMap

27--TODO: Fast patch type

23--TODO: Fast patch type

25+import Prelude hiding (lookup)

26+

29import Control.Monad.IO.Class

27import Control.Monad.IO.Class

30import Data.Foldable (traverse_)

28import Data.Foldable (traverse_)

31−import Data.IORef

32import Data.IntMap.Strict (IntMap)

29import Data.IntMap.Strict (IntMap)

33import qualified Data.IntMap.Strict as IntMap

30import qualified Data.IntMap.Strict as IntMap

34−import Data.Maybe

31+import Data.IORef

35−import Prelude hiding (lookup)

36import Reflex.Patch.Class

32import Reflex.Patch.Class

37import Reflex.Patch.IntMap

33import Reflex.Patch.IntMap

src/Data/FastWeakBag.hs+6−7

@@ -26,25 +26,24 @@ module Data.FastWeakBag

26#endif

27 ) where

29+import Prelude hiding (traverse)

30+

29−import Control.Monad hiding (forM_, mapM_)

31+import Control.Monad

30import Control.Monad.IO.Class

32import Control.Monad.IO.Class

32#ifdef GHCJS_FAST_WEAK

34#ifdef GHCJS_FAST_WEAK

33import GHCJS.Types

35import GHCJS.Types

34−import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)

36+import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)

35#else

37#else

36import Control.Exception

38import Control.Exception

37−import Data.Foldable (forM_, mapM_)

38import Data.IntMap.Strict (IntMap)

39import Data.IntMap.Strict (IntMap)

39import qualified Data.IntMap.Strict as IntMap

40import qualified Data.IntMap.Strict as IntMap

40import Data.IORef

41import Data.IORef

41import System.Mem.Weak

42import System.Mem.Weak

42#endif

43#endif

44−import Prelude hiding (mapM_, traverse)

45−

46−-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -

45+-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them -

47−-- that is, they can still be garbage-collected. As long as the @a@s remain

46+-- that is, they can still be garbage-collected. As long as the @/a/@ values remain

48-- alive, the 'FastWeakBag' will continue to refer to them.

47-- alive, the 'FastWeakBag' will continue to refer to them.

49#ifdef GHCJS_FAST_WEAK

48#ifdef GHCJS_FAST_WEAK

50newtype FastWeakBag a = FastWeakBag JSVal

49newtype FastWeakBag a = FastWeakBag JSVal

src/Data/Functor/Misc.hs+2−121

@@ -38,17 +38,10 @@ module Data.Functor.Misc

38 , dmapToThese

39 , eitherToDSum

40 , dsumToEither

41− -- * Deprecated functions

42− , sequenceDmap

43− , wrapDMap

44− , rewrapDMap

45− , unwrapDMap

46− , unwrapDMapMaybe

47− , extractFunctorDMap

48 , ComposeMaybe (..)

41 , ComposeMaybe (..)

49 ) where

42 ) where

51−import Control.Applicative (Applicative, (<$>))

44+import Control.Applicative ((<$>))

52import Control.Monad.Identity

45import Control.Monad.Identity

53import Data.Dependent.Map (DMap)

46import Data.Dependent.Map (DMap)

54import qualified Data.Dependent.Map as DMap

47import qualified Data.Dependent.Map as DMap

@@ -84,48 +77,22 @@ deriving instance Show k => Show (Const2 k v v')

84deriving instance Read k => Read (Const2 k v v)

77deriving instance Read k => Read (Const2 k v v)

86instance Show k => GShow (Const2 k v) where

79instance Show k => GShow (Const2 k v) where

87−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

88− gshowToShow (Const2 _) = id

89−#else

90 gshowsPrec n x@(Const2 _) = showsPrec n x

80 gshowsPrec n x@(Const2 _) = showsPrec n x

91−#endif

93instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where

82instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where

94−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

95− showTagToShow (Const2 _) _ = id

96−#else

97 showTaggedPrec (Const2 _) = showsPrec

83 showTaggedPrec (Const2 _) = showsPrec

98−#endif

100instance Eq k => GEq (Const2 k v) where

85instance Eq k => GEq (Const2 k v) where

101−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

102− geqToEq _ = id

103− geqUnify (Const2 _) (Const2 _) _ = id

104−#else

105 geq (Const2 a) (Const2 b) =

86 geq (Const2 a) (Const2 b) =

106 if a == b

87 if a == b

107 then Just Refl

88 then Just Refl

108 else Nothing

89 else Nothing

109−#endif

110

111instance Ord k => GCompare (Const2 k v) where

91instance Ord k => GCompare (Const2 k v) where

112−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

113− gcompareToOrd (Const2 _) = id

114− gcompare (Const2 a) (Const2 b) = strengthenOrdering $ compare a b

115−#else

116 gcompare (Const2 a) (Const2 b) = case compare a b of

92 gcompare (Const2 a) (Const2 b) = case compare a b of

117 LT -> GLT

93 LT -> GLT

118 EQ -> GEQ

94 EQ -> GEQ

119 GT -> GGT

95 GT -> GGT

120−#endif

121−

122−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

123−instance {-# INCOHERENT #-} (Eq k, Eq v) => EqTag (Const2 k v) Identity where

124− eqTagToEq (Const2 _) _ = id

125−

126−instance {-# INCOHERENT #-} Eq k => EqTag (Const2 k v) (Const2 k v) where

127− eqTagToEq (Const2 _) _ = id

128−#endif

129

130-- | Convert a 'DMap' to a regular 'Map'

97-- | Convert a 'DMap' to a regular 'Map'

131dmapToMap :: DMap (Const2 k v) Identity -> Map k v

98dmapToMap :: DMap (Const2 k v) Identity -> Map k v

@@ -175,17 +142,9 @@ deriving instance Show (f a) => Show (WrapArg g f (g' a))

175deriving instance Read (f a) => Read (WrapArg g f (g a))

142deriving instance Read (f a) => Read (WrapArg g f (g a))

176

143

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

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

178−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

179− geqToEq (WrapArg f) = geqToEq f

180− geqUnify (WrapArg a) (WrapArg b) = geqUnify a b

181−#else

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

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

183−#endif

184

146

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

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

186−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

187− gcompareToOrd (WrapArg f) = gcompareToOrd f

188−#endif

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

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

190 GLT -> GLT

149 GLT -> GLT

191 GEQ -> GEQ

150 GEQ -> GEQ

@@ -237,34 +196,13 @@ deriving instance Show (EitherTag l r a)

237deriving instance Eq (EitherTag l r a)

196deriving instance Eq (EitherTag l r a)

238deriving instance Ord (EitherTag l r a)

197deriving instance Ord (EitherTag l r a)

239

198

240−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

241−instance {-# INCOHERENT #-} (Show (f l), Show (f r)) => ShowTag (EitherTag l r) f where

242− showTagToShow e _ = case e of

243− LeftTag -> id

244− RightTag -> id

245−

246−instance {-# INCOHERENT #-} (Eq (f l), Eq (f r)) => EqTag (EitherTag l r) f where

247− eqTagToEq e _ = case e of

248− LeftTag -> id

249− RightTag -> id

250−#endif

251−

252instance GEq (EitherTag l r) where

199instance GEq (EitherTag l r) where

253−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

254− geqToEq _ = id

255− geqUnify LeftTag LeftTag _ same = same

256− geqUnify RightTag RightTag _ same = same

257− geqUnify _ _ unknown _ = unknown

258−#endif

259 geq a b = case (a, b) of

200 geq a b = case (a, b) of

260 (LeftTag, LeftTag) -> Just Refl

201 (LeftTag, LeftTag) -> Just Refl

261 (RightTag, RightTag) -> Just Refl

202 (RightTag, RightTag) -> Just Refl

262 _ -> Nothing

203 _ -> Nothing

263

204

264instance GCompare (EitherTag l r) where

205instance GCompare (EitherTag l r) where

265−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

266− gcompareToOrd _ = id

267−#endif

268 gcompare a b = case (a, b) of

206 gcompare a b = case (a, b) of

269 (LeftTag, LeftTag) -> GEQ

207 (LeftTag, LeftTag) -> GEQ

270 (LeftTag, RightTag) -> GLT

208 (LeftTag, RightTag) -> GLT

@@ -272,24 +210,14 @@ instance GCompare (EitherTag l r) where

272 (RightTag, RightTag) -> GEQ

210 (RightTag, RightTag) -> GEQ

273

211

274instance GShow (EitherTag l r) where

212instance GShow (EitherTag l r) where

275−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

276− gshowToShow _ = id

277−#else

278 gshowsPrec _ a = case a of

213 gshowsPrec _ a = case a of

279 LeftTag -> showString "LeftTag"

214 LeftTag -> showString "LeftTag"

280 RightTag -> showString "RightTag"

215 RightTag -> showString "RightTag"

281−#endif

282

216

283instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

217instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

284−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

285− showTagToShow t _ = case t of

286− LeftTag -> id

287− RightTag -> id

288−#else

289 showTaggedPrec t n (Identity a) = case t of

218 showTaggedPrec t n (Identity a) = case t of

290 LeftTag -> showsPrec n a

219 LeftTag -> showsPrec n a

291 RightTag -> showsPrec n a

220 RightTag -> showsPrec n a

292−#endif

293

221

294-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

222-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

295eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

223eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

@@ -310,54 +238,7 @@ dsumToEither = \case

310-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would

238-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would

311-- make the 'f' parameter have a nominal type role. We need f to be

239-- make the 'f' parameter have a nominal type role. We need f to be

312-- representational so that we can use safe 'coerce'.

240-- representational so that we can use safe 'coerce'.

313−#if MIN_VERSION_transformers(5,2,0)

314newtype ComposeMaybe f a =

241newtype ComposeMaybe f a =

315−#else

316−newtype ComposeMaybe (f :: * -> *) (a :: *) =

317−#endif

318− ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)

242+ ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)

319

243

320deriving instance Functor f => Functor (ComposeMaybe f)

244deriving instance Functor f => Functor (ComposeMaybe f)

321−

322−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

323−instance {-# INCOHERENT #-} EqTag f g => EqTag f (ComposeMaybe g) where

324− eqTagToEq f _ = eqTagToEq f (Proxy :: Proxy g)

325−

326−instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where

327− showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)

328−#endif

329−--------------------------------------------------------------------------------

330−-- Deprecated functions

331−--------------------------------------------------------------------------------

332−

333−{-# INLINE sequenceDmap #-}

334−{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}

335−-- | Run the actions contained in the 'DMap'

336−sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)

337−sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t

338−

339−{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}

340−-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor

341−wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f

342−wrapDMap f = DMap.map $ f . runIdentity

343−

344−{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}

345−-- | Replace one functor for a 'DMap''s values with a different functor

346−rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g

347−rewrapDMap = DMap.map

348−

349−{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}

350−-- | Replace one functor for a 'DMap''s values with the 'Identity' functor

351−unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity

352−unwrapDMap f = DMap.map $ Identity . f

353−

354−{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}

355−-- | Like 'unwrapDMap', but possibly delete some values from the DMap

356−unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity

357−unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a

358−

359−{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}

360−-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the

361−-- underlying functor

362−extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f

363−extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v

src/Data/Map/Misc.hs+27−11

@@ -1,5 +1,6 @@

1{-# LANGUAGE LambdaCase #-}

2+-- | Additional functions for manipulating 'Map's.

2−module Data.Map.Misc

3+module Data.Map.Misc

3 (

4 (

4 -- * Working with Maps

5 -- * Working with Maps

5 diffMapNoEq

6 diffMapNoEq

@@ -10,7 +11,6 @@ module Data.Map.Misc

10 ) where

11 ) where

12import Data.Align

13import Data.Align

13−import Data.Either

14import Data.Map (Map)

15import qualified Data.Map as Map

16import Data.Maybe

@@ -18,12 +18,21 @@ import Data.Set (Set)

18import qualified Data.Set as Set

19import Data.These

21+-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@

22+-- represents an association only present in @old@ but no longer present in @new@.

23+--

24+-- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not.

21diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

25diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

22diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case

26diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case

23 This _ -> Just Nothing

27 This _ -> Just Nothing

24 These _ new -> Just $ Just new

28 These _ new -> Just $ Just new

25 That new -> Just $ Just new

29 That new -> Just $ Just new

31+-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not

32+-- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@.

33+--

34+-- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between

35+-- @old@ and @new@ with @Nothing@.

27diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)

36diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)

28diffMap olds news = flip Map.mapMaybe (align olds news) $ \case

37diffMap olds news = flip Map.mapMaybe (align olds news) $ \case

29 This _ -> Just Nothing

38 This _ -> Just Nothing

@@ -32,23 +41,30 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case

32 | otherwise -> Just $ Just new

41 | otherwise -> Just $ Just new

33 That new -> Just $ Just new

42 That new -> Just $ Just new

44+-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@.

45+--

46+-- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'.

35applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v

47applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v

36applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)

48applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)

37− where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch

49+ where (deletions, insertions) = Map.mapEither maybeToEither patch

38 maybeToEither = \case

50 maybeToEither = \case

39 Nothing -> Left ()

51 Nothing -> Left ()

40 Just r -> Right r

52 Just r -> Right r

54+-- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@

55+{-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-}

42mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)

56mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)

43−mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)

57+mapPartitionEithers = Map.mapEither id

44− where (ls, rs) = Map.partition isLeft m

45− fromLeft (Left l) = l

46− fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"

47− fromRight (Right r) = r

48− fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"

50−-- | Apply a map patch to a set

59+-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new @'Set' k@ from the given input set.

60+--

61+-- Equivalent to:

62+--

63+-- @

51−-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)

64+-- applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m)

65+-- @

66+--

67+-- but avoids the intervening @Map@ and needs no values.

52applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k

68applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k

53applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)

69applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)

54 where (insertions, deletions) = Map.partition isJust patch

70 where (insertions, deletions) = Map.partition isJust patch

src/Data/WeakBag.hs+5−8

@@ -21,19 +21,18 @@ module Data.WeakBag

21 , _weakBag_children --TODO: Don't export this

22 ) where

24+import Prelude hiding (traverse)

25+

24import Control.Exception

26import Control.Exception

25−import Control.Monad hiding (forM_, mapM_)

27+import Control.Monad

26import Control.Monad.IO.Class

28import Control.Monad.IO.Class

27−import Data.Foldable (forM_, mapM_)

28import Data.IntMap.Strict (IntMap)

29import Data.IntMap.Strict (IntMap)

29import qualified Data.IntMap.Strict as IntMap

30import qualified Data.IntMap.Strict as IntMap

30import Data.IORef

31import Data.IORef

31import System.Mem.Weak

32import System.Mem.Weak

33−import Prelude hiding (mapM_, traverse)

34−

35−-- | A @WeakBag a@ holds a set of values of type @a@, but does not retain them -

34+-- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them -

36−-- that is, they can still be garbage-collected. As long as the @a@s remain

35+-- that is, they can still be garbage-collected. As long as the @/a/@ values remain

37-- alive, the 'WeakBag' will continue to refer to them.

36-- alive, the 'WeakBag' will continue to refer to them.

38data WeakBag a = WeakBag

37data WeakBag a = WeakBag

39 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?

38 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?

@@ -72,8 +71,6 @@ insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do

72 let !csWithoutMe = IntMap.delete myId cs

71 let !csWithoutMe = IntMap.delete myId cs

73 in (csWithoutMe, csWithoutMe)

72 in (csWithoutMe, csWithoutMe)

74 when (IntMap.null csWithoutMe) $ finalizer b

73 when (IntMap.null csWithoutMe) $ finalizer b

75− return ()

76− return ()

77 wa <- mkWeakPtr a' $ Just cleanup

74 wa <- mkWeakPtr a' $ Just cleanup

78 atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

75 atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

79 return $ WeakBagTicket

76 return $ WeakBagTicket

src/Reflex.hs+8−2

@@ -6,14 +6,20 @@ module Reflex

6 ) where

8import Reflex.Class as X

9+import Reflex.Adjustable.Class as X

10+import Reflex.BehaviorWriter.Base as X

11+import Reflex.BehaviorWriter.Class as X

9import Reflex.Collection as X

12import Reflex.Collection as X

10−import Reflex.EventWriter as X

11import Reflex.Dynamic as X

13import Reflex.Dynamic as X

14+import Reflex.EventWriter.Base as X

15+import Reflex.EventWriter.Class as X

12#ifdef USE_TEMPLATE_HASKELL

16#ifdef USE_TEMPLATE_HASKELL

13import Reflex.Dynamic.TH as X

17import Reflex.Dynamic.TH as X

14#endif

18#endif

15import Reflex.Dynamic.Uniq as X

19import Reflex.Dynamic.Uniq as X

16−import Reflex.DynamicWriter as X

20+import Reflex.DynamicWriter.Base as X

21+import Reflex.DynamicWriter.Class as X

22+import Reflex.NotReady.Class as X

17import Reflex.PerformEvent.Base as X

23import Reflex.PerformEvent.Base as X

18import Reflex.PerformEvent.Class as X

24import Reflex.PerformEvent.Class as X

19import Reflex.PostBuild.Base as X

25import Reflex.PostBuild.Base as X

src/Reflex/Adjustable/Class.hs+58−111

@@ -1,50 +1,39 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

3{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

4−{-# LANGUAGE RecursiveDo #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11#ifdef USE_REFLEX_OPTIMIZER

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

13#endif

14−module Reflex.Adjustable.Class

14+module Reflex.Adjustable.Class

15− (

15+ (

16 -- * The Adjustable typeclass

17 Adjustable(..)

18 , sequenceDMapWithAdjust

19 , sequenceDMapWithAdjustWithMove

20 , mapMapWithAdjustWithMove

21− -- * Widgets on Collections

21+ -- * Deprecated aliases

22− , listHoldWithKey

22+ , MonadAdjust

23− , listWithKey

24− , listWithKey'

25− , listWithKeyShallowDiff

26− , listViewWithKey

27− , selectViewListWithKey

28− , selectViewListWithKey_

29− -- * List Utils

30− , list

31− , simpleList

32 ) where

23 ) where

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

25+import Control.Monad.Identity

35−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

26+import Control.Monad.Reader

36−import Data.Align

37−import Data.Map (Map)

38−import qualified Data.Map as Map

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

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

28+import qualified Data.Dependent.Map as DMap

40import Data.Functor.Constant

29import Data.Functor.Constant

41import Data.Functor.Misc

30import Data.Functor.Misc

42−import Data.Map.Misc

31+import Data.IntMap.Strict (IntMap)

32+import qualified Data.IntMap.Strict as IntMap

43−import Data.These

33+import Data.Map (Map)

45import Reflex.Class

35import Reflex.Class

46−import Reflex.Dynamic

36+import Reflex.Patch.DMapWithMove

47−import Reflex.PostBuild.Class

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

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

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

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

@@ -53,10 +42,43 @@ import Reflex.PostBuild.Class

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

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

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

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

55class (Reflex t, Monad m) => Adjustable t m | m -> t where

44class (Reflex t, Monad m) => Adjustable t m | m -> t where

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

45+ runWithReplace

46+ :: m a

47+ -> Event t (m b)

48+ -> m (a, Event t b)

49+

57− traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))

50+ traverseIntMapWithKeyWithAdjust

51+ :: (IntMap.Key -> v -> m v')

52+ -> IntMap v

53+ -> Event t (PatchIntMap v)

54+ -> m (IntMap v', Event t (PatchIntMap v'))

55+

58− traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))

56+ traverseDMapWithKeyWithAdjust

57+ :: GCompare k

58+ => (forall a. k a -> v a -> m (v' a))

59+ -> DMap k v

60+ -> Event t (PatchDMap k v)

61+ -> m (DMap k v', Event t (PatchDMap k v'))

62+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

63+ traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $

64+ traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'

65+ where

66+ toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m

67+ toNodeInfoWithMove = \case

68+ ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing

69+ ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing

70+ fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m

71+ fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of

72+ From_Insert v -> Just v

73+ From_Delete -> Nothing

74+ From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"

75+

76+ traverseDMapWithKeyWithAdjustWithMove

77+ :: GCompare k

78+ => (forall a. k a -> v a -> m (v' a))

79+ -> DMap k v

80+ -> Event t (PatchDMapWithMove k v)

59− traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))

81+ -> m (DMap k v', Event t (PatchDMapWithMove k v'))

61instance Adjustable t m => Adjustable t (ReaderT r m) where

83instance Adjustable t m => Adjustable t (ReaderT r m) where

62 runWithReplace a0 a' = do

84 runWithReplace a0 a' = do

@@ -83,84 +105,9 @@ mapMapWithAdjustWithMove f m0 m' = do

83 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

105 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

84 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

106 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

107

86−listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))

108+--------------------------------------------------------------------------------

87−listHoldWithKey m0 m' f = do

109+-- Deprecated functions

88− let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

110+--------------------------------------------------------------------------------

89− dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'

90− (a0, a') <- sequenceDMapWithAdjust dm0 dm'

91− fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time

92−

93−--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

94−listWithKey :: forall t k v m a. (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

95−listWithKey vals mkChild = do

96− postBuild <- getPostBuild

97− let childValChangedSelector = fanMap $ updated vals

98− -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey

99− -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges

100− -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.

101− diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case

102− This _ -> Just Nothing

103− These _ _ -> Nothing

104− That new -> Just $ Just new

105− rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals

106− let changeVals :: Event t (Map k (Maybe v))

107− changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost

108− [ updated vals

109− , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work

110− ]

111− listHoldWithKey Map.empty changeVals $ \k v ->

112− mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)

113−

114−{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}

115−listWithKey' :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

116−listWithKey' = listWithKeyShallowDiff

117−

118−-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.

119−listWithKeyShallowDiff :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

120−listWithKeyShallowDiff initialVals valsChanged mkChild = do

121− let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged

122− sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged

123− let relevantPatch patch _ = case patch of

124− Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored

125− Just _ -> Nothing -- We don't want to let spurious re-creations of items through

126− listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->

127− mkChild k v $ select childValChangedSelector $ Const2 k

128−

129−--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

130−-- | Create a dynamically-changing set of Event-valued widgets.

131−-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.

132−listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))

133−listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild

134−

135−listViewWithKey' :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

136−listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

137−

138−-- | Create a dynamically-changing set of widgets, one of which is selected at any time.

139−selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

140− => Dynamic t k -- ^ Current selection key

141− -> Dynamic t (Map k v) -- ^ Dynamic key/value map

142− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

143− -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

144−selectViewListWithKey selection vals mkChild = do

145− let selectionDemux = demux selection -- For good performance, this value must be shared across all children

146− selectChild <- listWithKey vals $ \k v -> do

147− let selected = demuxed selectionDemux k

148− selectSelf <- mkChild k v selected

149− return $ fmap ((,) k) selectSelf

150− return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

151−

152−selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

153− => Dynamic t k -- ^ Current selection key

154− -> Dynamic t (Map k v) -- ^ Dynamic key/value map

155− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

156− -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

157−selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

158−

159−-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.

160−-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.

161−list :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))

162−list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

163

111

164−-- | Create a dynamically-changing set of widgets from a Dynamic list.

112+{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}

165−simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])

113+type MonadAdjust = Adjustable

166−simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs

src/Reflex/BehaviorWriter/Base.hsnew file+202

@@ -0,0 +1,202 @@

1+{-|

2+Module: Reflex.BehaviorWriter.Base

3+Description: Implementation of MonadBehaviorWriter

4+-}

5+{-# LANGUAGE CPP #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE StandaloneDeriving #-}

15+#ifdef USE_REFLEX_OPTIMIZER

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

17+#endif

18+module Reflex.BehaviorWriter.Base

19+ ( BehaviorWriterT (..)

20+ , runBehaviorWriterT

21+ , withBehaviorWriterT

22+ ) where

23+

24+import Control.Monad.Exception

25+import Control.Monad.Identity

26+import Control.Monad.IO.Class

27+import Control.Monad.Reader

28+import Control.Monad.Ref

29+import Control.Monad.State.Strict

30+import Data.Dependent.Map (DMap)

31+import qualified Data.Dependent.Map as DMap

32+import Data.Functor.Misc

33+import Data.IntMap (IntMap)

34+import qualified Data.IntMap as IntMap

35+import Data.Map (Map)

36+import qualified Data.Map as Map

37+import Data.Some (Some)

38+

39+import Reflex.Class

40+import Reflex.Adjustable.Class

41+import Reflex.BehaviorWriter.Class

42+import Reflex.Host.Class

43+import Reflex.PerformEvent.Class

44+import Reflex.PostBuild.Class

45+import Reflex.Query.Class

46+import Reflex.Requester.Class

47+import Reflex.TriggerEvent.Class

48+

49+-- | A basic implementation of 'MonadBehaviorWriter'.

50+newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }

51+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order

52+

53+-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided

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

55+runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)

56+runBehaviorWriterT (BehaviorWriterT a) = do

57+ (result, ws) <- runStateT a []

58+ return (result, mconcat $ reverse ws)

59+

60+-- | Map a function over the output of a 'BehaviorWriterT'.

61+withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)

62+ => (w -> w')

63+ -> BehaviorWriterT t w m a

64+ -> BehaviorWriterT t w' m a

65+withBehaviorWriterT f dw = do

66+ (r, d) <- lift $ do

67+ (r, d) <- runBehaviorWriterT dw

68+ let d' = fmap f d

69+ return (r, d')

70+ tellBehavior d

71+ return r

72+

73+deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)

74+deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)

75+

76+instance MonadTrans (BehaviorWriterT t w) where

77+ lift = BehaviorWriterT . lift

78+

79+instance MonadRef m => MonadRef (BehaviorWriterT t w m) where

80+ type Ref (BehaviorWriterT t w m) = Ref m

81+ newRef = lift . newRef

82+ readRef = lift . readRef

83+ writeRef r = lift . writeRef r

84+

85+instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where

86+ atomicModifyRef r = lift . atomicModifyRef r

87+

88+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where

89+ newEventWithTrigger = lift . newEventWithTrigger

90+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

91+

92+instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where

93+ tellBehavior w = BehaviorWriterT $ modify (w :)

94+

95+instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where

96+ ask = lift ask

97+ local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a

98+ reader = lift . reader

99+

100+instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where

101+ type Performable (BehaviorWriterT t w m) = Performable m

102+ performEvent_ = lift . performEvent_

103+ performEvent = lift . performEvent

104+

105+instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where

106+ newTriggerEvent = lift newTriggerEvent

107+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

108+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

109+

110+instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where

111+ getPostBuild = lift getPostBuild

112+

113+instance MonadState s m => MonadState s (BehaviorWriterT t w m) where

114+ get = lift get

115+ put = lift . put

116+

117+instance Requester t m => Requester t (BehaviorWriterT t w m) where

118+ type Request (BehaviorWriterT t w m) = Request m

119+ type Response (BehaviorWriterT t w m) = Response m

120+ requesting = lift . requesting

121+ requesting_ = lift . requesting_

122+

123+instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where

124+ tellQueryIncremental = lift . tellQueryIncremental

125+ askQueryResult = lift askQueryResult

126+ queryIncremental = lift . queryIncremental

127+

128+instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where

129+ runWithReplace a0 a' = do

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

131+ tellBehavior . join =<< hold (snd result0) (snd <$> result')

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

133+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust

134+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith

135+

136+traverseIntMapWithKeyWithAdjustImpl

137+ :: forall t w v' p p' v m.

138+ ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)

139+ , Patch (p' (Behavior t w))

140+ , Monoid w

141+ , Reflex t

142+ , MonadHold t m

143+ , Functor p

144+ , p ~ p'

145+ )

146+ => ( (IntMap.Key -> v -> m (v', Behavior t w))

147+ -> IntMap v

148+ -> Event t (p v)

149+ -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))

150+ )

151+ -> (IntMap.Key -> v -> BehaviorWriterT t w m v')

152+ -> IntMap v

153+ -> Event t (p v)

154+ -> BehaviorWriterT t w m (IntMap v', Event t (p v'))

155+traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do

156+ (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'

157+ let liftedResult0 = fmap fst result0

158+ liftedResult' = fmap (fmap fst) result'

159+ liftedWritten0 :: IntMap (Behavior t w)

160+ liftedWritten0 = fmap snd result0

161+ liftedWritten' = fmap (fmap snd) result'

162+ i <- holdIncremental liftedWritten0 liftedWritten'

163+ tellBehavior $ pull $ do

164+ m <- sample $ currentIncremental i

165+ mconcat . IntMap.elems <$> traverse sample m

166+ return (liftedResult0, liftedResult')

167+

168+newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)

169+

170+traverseDMapWithKeyWithAdjustImpl

171+ :: forall t w k v' p p' v m.

172+ ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)

173+ , Patch (p' (Some k) (Behavior t w))

174+ , Monoid w

175+ , Reflex t

176+ , MonadHold t m

177+ )

178+ => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))

179+ -> DMap k v

180+ -> Event t (p k v)

181+ -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))

182+ )

183+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')

184+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))

185+ -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))

186+ -> DMap k v

187+ -> Event t (p k v)

188+ -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))

189+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do

190+ (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'

191+ let getValue (BehaviorWriterTLoweredResult (v, _)) = v

192+ getWritten (BehaviorWriterTLoweredResult (_, w)) = w

193+ liftedResult0 = DMap.map getValue result0

194+ liftedResult' = ffor result' $ mapPatch getValue

195+ liftedWritten0 :: Map (Some k) (Behavior t w)

196+ liftedWritten0 = weakenDMapWith getWritten result0

197+ liftedWritten' = ffor result' $ weakenPatchWith getWritten

198+ i <- holdIncremental liftedWritten0 liftedWritten'

199+ tellBehavior $ pull $ do

200+ m <- sample $ currentIncremental i

201+ mconcat . Map.elems <$> traverse sample m

202+ return (liftedResult0, liftedResult')

src/Reflex/BehaviorWriter/Class.hsnew file+26

@@ -0,0 +1,26 @@

1+{-|

2+Module: Reflex.BehaviorWriter.Class

3+Description: This module defines the 'MonadBehaviorWriter' class

4+-}

5+{-# LANGUAGE CPP #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE FunctionalDependencies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+#ifdef USE_REFLEX_OPTIMIZER

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

12+#endif

13+module Reflex.BehaviorWriter.Class

14+ ( MonadBehaviorWriter (..)

15+ ) where

16+

17+import Control.Monad.Reader (ReaderT, lift)

18+import Reflex.Class (Behavior)

19+

20+-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'

21+-- and combines them monoidally to provide a 'Behavior' result.

22+class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where

23+ tellBehavior :: Behavior t w -> m ()

24+

25+instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where

26+ tellBehavior = lift . tellBehavior

src/Reflex/Class.hs+547−326

@@ -1,5 +1,6 @@

1−{-# LANGUAGE ConstraintKinds #-}

1+{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

3+{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DefaultSignatures #-}

4{-# LANGUAGE DefaultSignatures #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

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

8{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE NoMonomorphismRestriction #-}

11{-# LANGUAGE NoMonomorphismRestriction #-}

12+{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE RecursiveDo #-}

13{-# LANGUAGE RoleAnnotations #-}

15{-# LANGUAGE RoleAnnotations #-}

@@ -18,14 +20,14 @@

18#ifdef USE_REFLEX_OPTIMIZER

20#ifdef USE_REFLEX_OPTIMIZER

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

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

20#endif

22#endif

21−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

22−{-# LANGUAGE EmptyDataDecls #-}

23−{-# OPTIONS_GHC -Wno-redundant-constraints #-}

24−#endif

24+-- |

25+-- Module:

26+-- Reflex.Class

27+-- Description:

26−-- | This module contains the Reflex interface, as well as a variety of

28+-- This module contains the Reflex interface, as well as a variety of

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

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

28−-- signals.

30+-- signals.

29module Reflex.Class

31module Reflex.Class

30 ( module Reflex.Patch

32 ( module Reflex.Patch

31 -- * Primitives

33 -- * Primitives

@@ -36,19 +38,22 @@ module Reflex.Class

36 , coerceDynamic

38 , coerceDynamic

37 , MonadSample (..)

39 , MonadSample (..)

38 , MonadHold (..)

40 , MonadHold (..)

39− -- ** 'fan'-related types

41+ -- ** 'fan' related types

40 , EventSelector (..)

42 , EventSelector (..)

41 , EventSelectorInt (..)

43 , EventSelectorInt (..)

42− -- ** 'Incremental'-related types

43 -- * Convenience functions

44 -- * Convenience functions

44 , constDyn

45 , constDyn

45 , pushAlways

46 , pushAlways

46 -- ** Combining 'Event's

47 -- ** Combining 'Event's

47 , leftmost

48 , leftmost

48 , mergeMap

49 , mergeMap

50+ , mergeIntMap

49 , mergeMapIncremental

51 , mergeMapIncremental

50 , mergeMapIncrementalWithMove

52 , mergeMapIncrementalWithMove

51 , mergeIntMapIncremental

53 , mergeIntMapIncremental

54+ , coincidencePatchMap

55+ , coincidencePatchMapWithMove

56+ , coincidencePatchIntMap

52 , mergeList

57 , mergeList

53 , mergeWith

58 , mergeWith

54 , difference

59 , difference

@@ -62,11 +67,16 @@ module Reflex.Class

62 , EitherTag (..)

67 , EitherTag (..)

63 , eitherToDSum

68 , eitherToDSum

64 , dsumToEither

69 , dsumToEither

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

70+ , factorEvent

66− , switchPromptly

71+ , filterEventKey

67− , switchPromptOnly

72+ -- ** Collapsing 'Event . Event'

73+ , switchHold

74+ , switchHoldPromptly

75+ , switchHoldPromptOnly

76+ , switchHoldPromptOnlyIncremental

68 -- ** Using 'Event's to sample 'Behavior's

77 -- ** Using 'Event's to sample 'Behavior's

69 , tag

78 , tag

79+ , tagMaybe

70 , attach

80 , attach

71 , attachWith

81 , attachWith

72 , attachWithMaybe

82 , attachWithMaybe

@@ -100,6 +110,14 @@ module Reflex.Class

100 , mapAccumM_

110 , mapAccumM_

101 , mapAccumMaybe_

111 , mapAccumMaybe_

102 , mapAccumMaybeM_

112 , mapAccumMaybeM_

113+ , accumIncremental

114+ , accumMIncremental

115+ , accumMaybeIncremental

116+ , accumMaybeMIncremental

117+ , mapAccumIncremental

118+ , mapAccumMIncremental

119+ , mapAccumMaybeIncremental

120+ , mapAccumMaybeMIncremental

103 , zipListWithEvent

121 , zipListWithEvent

104 , numberOccurrences

122 , numberOccurrences

105 , numberOccurrencesFrom

123 , numberOccurrencesFrom

@@ -109,6 +127,9 @@ module Reflex.Class

109 , tailE

127 , tailE

110 , headTailE

128 , headTailE

111 , takeWhileE

129 , takeWhileE

130+ , takeWhileJustE

131+ , dropWhileE

132+ , takeDropWhileJustE

112 , switcher

133 , switcher

113 -- * Debugging functions

134 -- * Debugging functions

114 , traceEvent

135 , traceEvent

@@ -116,25 +137,24 @@ module Reflex.Class

116 -- * Unsafe functions

137 -- * Unsafe functions

117 , unsafeDynamic

138 , unsafeDynamic

118 , unsafeMapIncremental

139 , unsafeMapIncremental

119− -- * 'FunctorMaybe'

140+ -- * 'Filterable' convenience functions

120− , FunctorMaybe (..)

141+ , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead

142+ , mapMaybe -- Re-exported for convenience

143+ , fmapMaybe

121 , fforMaybe

144 , fforMaybe

122 , ffilter

145 , ffilter

123 , filterLeft

146 , filterLeft

124 , filterRight

147 , filterRight

125− -- * 'Adjustable'

126− , Adjustable(..)

127− , sequenceDMapWithAdjust

128− , sequenceDMapWithAdjustWithMove

129− , mapMapWithAdjustWithMove

130 -- * Miscellaneous convenience functions

148 -- * Miscellaneous convenience functions

131 , ffor

149 , ffor

150+ , ffor2

151+ , ffor3

132 -- * Deprecated functions

152 -- * Deprecated functions

133− , MonadAdjust

153+ , switchPromptly

134− , appendEvents

154+ , switchPromptOnly

135− , onceE

155+ -- * "Cheap" functions

136− , sequenceThese

137 , fmapMaybeCheap

156 , fmapMaybeCheap

157+ , mapMaybeCheap

138 , fmapCheap

158 , fmapCheap

139 , fforCheap

159 , fforCheap

140 , fforMaybeCheap

160 , fforMaybeCheap

@@ -144,97 +164,51 @@ module Reflex.Class

144 , mergeWithCheap'

164 , mergeWithCheap'

145 -- * Slow, but general, implementations

165 -- * Slow, but general, implementations

146 , slowHeadE

166 , slowHeadE

147−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

148− , Spider

149− , SpiderEnv

150− , SpiderTimeline

151− , Global

152− , Behavior (..)

153− , Event (..)

154− , Dynamic (..)

155− , Incremental (..)

156− , never

157− , constant

158− , push

159− , pushCheap

160− , pull

161− , merge

162− , fan

163− , switch

164− , coincidence

165− , current

166− , updated

167− , unsafeBuildDynamic

168− , unsafeBuildIncremental

169− , mergeIncremental

170− , mergeIncrementalWithMove

171− , currentIncremental

172− , updatedIncremental

173− , incrementalToDynamic

174− , behaviorCoercion

175− , eventCoercion

176− , dynamicCoercion

177−#endif

178 ) where

167 ) where

179

168

180import Control.Applicative

169import Control.Applicative

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

170+import Control.Monad.Identity

182−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

171+import Control.Monad.Reader

183−import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

172+import Control.Monad.State.Strict

184−import Control.Monad.Trans.Cont (ContT ())

173+import Control.Monad.Trans.Cont (ContT)

185−import Control.Monad.Trans.Except (ExceptT ())

174+import Control.Monad.Trans.Except (ExceptT)

186−import Control.Monad.Trans.RWS (RWST ())

175+import Control.Monad.Trans.RWS (RWST)

187−import Control.Monad.Trans.Writer (WriterT ())

176+import Control.Monad.Trans.Writer (WriterT)

188import Data.Align

177import Data.Align

189import Data.Bifunctor

178import Data.Bifunctor

190import Data.Coerce

179import Data.Coerce

191import Data.Default

180import Data.Default

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

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

193import qualified Data.Dependent.Map as DMap

182import qualified Data.Dependent.Map as DMap

194−import Data.Either

183+import Data.Functor.Compose

184+import Data.Functor.Product

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

186+import Data.FastMutableIntMap (PatchIntMap)

195import Data.Foldable

187import Data.Foldable

196−import Data.Functor.Bind hiding (join)

188+import Data.Functor.Bind

197−import qualified Data.Functor.Bind as Bind

198−import Data.Functor.Constant

199import Data.Functor.Misc

189import Data.Functor.Misc

200import Data.Functor.Plus

190import Data.Functor.Plus

201import Data.IntMap.Strict (IntMap)

191import Data.IntMap.Strict (IntMap)

202import qualified Data.IntMap.Strict as IntMap

192import qualified Data.IntMap.Strict as IntMap

203import Data.List.NonEmpty (NonEmpty (..))

193import Data.List.NonEmpty (NonEmpty (..))

204import Data.Map (Map)

194import Data.Map (Map)

205−import Data.Maybe

206−import Data.Monoid hiding (Alt, (<>))

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

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

196+import Data.Some (Some)

197+import qualified Data.Some as Some

208import Data.String

198import Data.String

209import Data.These

199import Data.These

210−import Data.Traversable

211import Data.Type.Coercion

200import Data.Type.Coercion

201+import Data.Witherable (Filterable(..))

202+import qualified Data.Witherable as W

203+import Reflex.FunctorMaybe (FunctorMaybe)

212−import Reflex.FunctorMaybe

204+import qualified Reflex.FunctorMaybe

213import Reflex.Patch

205import Reflex.Patch

214−import Data.FastMutableIntMap (PatchIntMap)

206+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

215−

216−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

217−import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),

218− SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,

219− dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,

220− dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,

221− runFrame, runSpiderHostFrame)

222−import qualified Reflex.Spider.Internal

223−import qualified Reflex.Spider.Internal as S

224−import Unsafe.Coerce

225−#endif

226−

227−-- Note: must come last to silence warnings due to AMP on GHC < 7.10

228−import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

229

207

230import Debug.Trace (trace)

208import Debug.Trace (trace)

231

209

232−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

233−#include "Spider/SpiderTimeline.include.hs"

234−#endif

235−

236-- | The 'Reflex' class contains all the primitive functionality needed for

210-- | The 'Reflex' class contains all the primitive functionality needed for

237−-- Functional Reactive Programming (FRP). The @t@ type parameter indicates

211+-- Functional Reactive Programming (FRP). The @/t/@ type parameter indicates

238-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

212-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

239-- and the type of the timeline determines the FRP engine to be used. For most

213-- and the type of the timeline determines the FRP engine to be used. For most

240-- purposes, the 'Reflex.Spider' implementation is recommended.

214-- purposes, the 'Reflex.Spider' implementation is recommended.

@@ -244,9 +218,6 @@ class ( MonadHold t (PushM t)

244 , Functor (Dynamic t)

218 , Functor (Dynamic t)

245 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

219 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

246 , Monad (Dynamic t)

220 , Monad (Dynamic t)

247−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

248− , t ~ SpiderTimeline Global

249−#endif

250 ) => Reflex t where

221 ) => Reflex t where

251 -- | A container for a value that can change over time. 'Behavior's can be

222 -- | A container for a value that can change over time. 'Behavior's can be

252 -- sampled at will, but it is not possible to be notified when they change

223 -- sampled at will, but it is not possible to be notified when they change

@@ -269,7 +240,6 @@ class ( MonadHold t (PushM t)

269 type PushM t :: * -> *

240 type PushM t :: * -> *

270 -- | A monad for doing complex pull-based calculations efficiently

241 -- | A monad for doing complex pull-based calculations efficiently

271 type PullM t :: * -> *

242 type PullM t :: * -> *

272−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

273 -- | An 'Event' with no occurrences

243 -- | An 'Event' with no occurrences

274 never :: Event t a

244 never :: Event t a

275 -- | Create a 'Behavior' that always has the given value

245 -- | Create a 'Behavior' that always has the given value

@@ -284,7 +254,7 @@ class ( MonadHold t (PushM t)

284 -- recomputed whenever any of the read 'Behavior's changes

254 -- recomputed whenever any of the read 'Behavior's changes

285 pull :: PullM t a -> Behavior t a

255 pull :: PullM t a -> Behavior t a

286 -- | Merge a collection of events; the resulting 'Event' will only occur if at

256 -- | Merge a collection of events; the resulting 'Event' will only occur if at

287− -- least one input event is occuring, and will contain all of the input keys

257+ -- least one input event is occurring, and will contain all of the input keys

288 -- that are occurring simultaneously

258 -- that are occurring simultaneously

289 merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

259 merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

290 -- | Efficiently fan-out an event to many destinations. This function should

260 -- | Efficiently fan-out an event to many destinations. This function should

@@ -294,8 +264,7 @@ class ( MonadHold t (PushM t)

294 -- | Create an 'Event' that will occur whenever the currently-selected input

264 -- | Create an 'Event' that will occur whenever the currently-selected input

295 -- 'Event' occurs

265 -- 'Event' occurs

296 switch :: Behavior t (Event t a) -> Event t a

266 switch :: Behavior t (Event t a) -> Event t a

297− -- | Create an 'Event' that will occur whenever the input event is occurring

267+ -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring

298− -- and its occurrence value, another 'Event', is also occurring

299 coincidence :: Event t (Event t a) -> Event t a

268 coincidence :: Event t (Event t a) -> Event t a

300 -- | Extract the 'Behavior' of a 'Dynamic'.

269 -- | Extract the 'Behavior' of a 'Dynamic'.

301 current :: Dynamic t a -> Behavior t a

270 current :: Dynamic t a -> Behavior t a

@@ -304,7 +273,7 @@ class ( MonadHold t (PushM t)

304 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

273 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

305 -- recent firing of the given 'Event', if any.

274 -- recent firing of the given 'Event', if any.

306 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a

275 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a

307− -- | Create a new 'Incremental'. The given 'PullM''s value must always change

276+ -- | Create a new 'Incremental'. The given "PullM"'s value must always change

308 -- in the same way that the accumulated application of patches would change

277 -- in the same way that the accumulated application of patches would change

309 -- that value.

278 -- that value.

310 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

279 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

@@ -329,84 +298,11 @@ class ( MonadHold t (PushM t)

329 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

298 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

330 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

299 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

331 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

300 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

332−#endif

333

301

334--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

302--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

335mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

303mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

336mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

304mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

337

305

338−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

339−instance t ~ SpiderTimeline Global => Reflex t where

340− newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

341− newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }

342− newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Reflex.Spider.Internal.Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)

343− newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Reflex.Spider.Internal.Dynamic Global p }

344− type PullM t = SpiderPullM Global

345− type PushM t = SpiderPushM Global

346−never :: Reflex t => Event t a

347−constant :: Reflex t => a -> Behavior t a

348−push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

349−pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

350−pull :: Reflex t => PullM t a -> Behavior t a

351−merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)

352−fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k

353−switch :: Reflex t => Behavior t (Event t a) -> Event t a

354−coincidence :: Reflex t => Event t (Event t a) -> Event t a

355−current :: Reflex t => Dynamic t a -> Behavior t a

356−updated :: Reflex t => Dynamic t a -> Event t a

357−unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a

358−unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p

359−mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

360−mergeIncrementalWithMove :: (Reflex t, GCompare k) => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

361−currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)

362−updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p

363−incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)

364−behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)

365−eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)

366−dynamicCoercion :: Reflex t => Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

367−{-# INLINE never #-}

368−never = SpiderEvent S.eventNever

369−{-# INLINE constant #-}

370−constant = SpiderBehavior . S.behaviorConst

371−{-# INLINE push #-}

372−push f = SpiderEvent . S.push (coerce f) . unSpiderEvent

373−{-# INLINE pushCheap #-}

374−pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent

375−{-# INLINE pull #-}

376−pull = SpiderBehavior . S.pull . coerce

377−{-# INLINE merge #-}

378−merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))

379−{-# INLINE fan #-}

380−fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))

381−{-# INLINE switch #-}

382−switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior

383−{-# INLINE coincidence #-}

384−coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent

385−{-# INLINE current #-}

386−current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

387−{-# INLINE updated #-}

388−updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic

389−{-# INLINE unsafeBuildDynamic #-}

390−unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

391−{-# INLINE unsafeBuildIncremental #-}

392−unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ S.unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

393−{-# INLINE mergeIncremental #-}

394−mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental

395−{-# INLINE mergeIncrementalWithMove #-}

396−mergeIncrementalWithMove = SpiderEvent . S.mergeWithMove . (unsafeCoerce :: S.Dynamic x (PatchDMapWithMove k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMapWithMove k (S.Event x))) . unSpiderIncremental

397−{-# INLINE currentIncremental #-}

398−currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

399−{-# INLINE updatedIncremental #-}

400−updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

401−{-# INLINE incrementalToDynamic #-}

402−incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do

403− c <- readBehaviorUntracked $ dynamicCurrent i

404− return $ Identity <$> apply p c

405−eventCoercion Coercion = Coercion

406−behaviorCoercion Coercion = Coercion

407−dynamicCoercion = unsafeCoerce

408−#endif

409−

410-- | Coerce a 'Behavior' between representationally-equivalent value types

306-- | Coerce a 'Behavior' between representationally-equivalent value types

411coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

307coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

412coerceBehavior = coerceWith $ behaviorCoercion Coercion

308coerceBehavior = coerceWith $ behaviorCoercion Coercion

@@ -420,7 +316,7 @@ coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

420coerceDynamic = coerceWith $ dynamicCoercion Coercion

316coerceDynamic = coerceWith $ dynamicCoercion Coercion

421

317

422-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

318-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

423−-- _must_ change when and only when the 'Event' fires, such that the

319+-- __must__ change when and only when the 'Event' fires, such that the

424-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

320-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

425-- if this is not the case, the resulting 'Dynamic' will behave

321-- if this is not the case, the resulting 'Dynamic' will behave

426-- nondeterministically.

322-- nondeterministically.

@@ -448,7 +344,7 @@ class MonadSample t m => MonadHold t m where

448 -- value and will be updated whenever the given 'Event' occurs. The update

344 -- value and will be updated whenever the given 'Event' occurs. The update

449 -- takes effect immediately after the 'Event' occurs; if the occurrence that

345 -- takes effect immediately after the 'Event' occurs; if the occurrence that

450 -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample

346 -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample

451− -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new

347+ -- the 'Behavior', it will see the __old__ value of the 'Behavior', not the new

452 -- one.

348 -- one.

453 hold :: a -> Event t a -> m (Behavior t a)

349 hold :: a -> Event t a -> m (Behavior t a)

454 default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)

350 default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)

@@ -463,15 +359,44 @@ class MonadSample t m => MonadHold t m where

463 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

359 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

464 default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

360 default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

465 holdIncremental v0 = lift . holdIncremental v0

361 holdIncremental v0 = lift . holdIncremental v0

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

362+ buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)

467 {-

363 {-

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

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

469 buildDynamic getV0 = lift . buildDynamic getV0

365 buildDynamic getV0 = lift . buildDynamic getV0

470 -}

366 -}

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

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

472 -- the supplied 'Event'.

368 -- the supplied 'Event'.

473 headE :: Event t a -> m (Event t a)

369 headE :: Event t a -> m (Event t a)

474

370

371+accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p)

372+accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o

373+accumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t p) -> PatchTarget p -> Event t b -> m (Incremental t p)

374+accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o

375+accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p)

376+accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o

377+accumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p)) -> PatchTarget p -> Event t b -> m (Incremental t p)

378+accumMaybeMIncremental f z e = do

379+ rec let e' = flip push e $ \o -> do

380+ v <- sample $ currentIncremental d'

381+ f v o

382+ d' <- holdIncremental z e'

383+ return d'

384+mapAccumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)

385+mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o

386+mapAccumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)

387+mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o

388+mapAccumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)

389+mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o

390+mapAccumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)

391+mapAccumMaybeMIncremental f z e = do

392+ rec let e' = flip push e $ \o -> do

393+ v <- sample $ currentIncremental d'

394+ result <- f v o

395+ return $ case result of

396+ (Nothing, Nothing) -> Nothing

397+ _ -> Just result

398+ d' <- holdIncremental z $ mapMaybe fst e'

399+ return (d', mapMaybe snd e')

475

400

476slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

401slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

477slowHeadE e = do

402slowHeadE e = do

@@ -481,14 +406,14 @@ slowHeadE e = do

481

406

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

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

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

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

484−-- 'fmapMaybe'.

409+-- 'mapMaybe'.

485newtype EventSelector t k = EventSelector

410newtype EventSelector t k = EventSelector

486 { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is

411 { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is

487 -- determined by the type of the key, so this can be used to fan-out

412 -- determined by the type of the key, so this can be used to fan-out

488 -- 'Event's whose sub-'Event's have different types.

413 -- 'Event's whose sub-'Event's have different types.

489 --

414 --

490 -- Using 'EventSelector's and the 'fan' primitive is far more efficient than

415 -- Using 'EventSelector's and the 'fan' primitive is far more efficient than

491− -- (but equivalent to) using 'fmapMaybe' to select only the relevant

416+ -- (but equivalent to) using 'mapMaybe' to select only the relevant

492 -- occurrences of an 'Event'.

417 -- occurrences of an 'Event'.

493 select :: forall a. k a -> Event t a

418 select :: forall a. k a -> Event t a

494 }

419 }

@@ -572,6 +497,14 @@ pushAlways f = push (fmap Just . f)

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

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

573ffor = flip fmap

498ffor = flip fmap

574

499

500+-- | Rotated version of 'liftA2'.

501+ffor2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c

502+ffor2 a b f = liftA2 f a b

503+

504+-- | Rotated version of 'liftA3'.

505+ffor3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d

506+ffor3 a b c f = liftA3 f a b c

507+

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

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

576 pure = constant

509 pure = constant

577 f <*> x = pull $ sample f `ap` sample x

510 f <*> x = pull $ sample f `ap` sample x

@@ -615,6 +548,15 @@ instance (Reflex t, Num a) => Num (Behavior t a) where

615 negate = fmap negate

548 negate = fmap negate

616 signum = fmap signum

549 signum = fmap signum

617

550

551+instance (Num a, Reflex t) => Num (Dynamic t a) where

552+ (+) = liftA2 (+)

553+ (*) = liftA2 (*)

554+ abs = fmap abs

555+ signum = fmap signum

556+ fromInteger = pure . fromInteger

557+ negate = fmap negate

558+ (-) = liftA2 (-)

559+

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

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

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

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

620 sconcat = pull . fmap sconcat . mapM sample

562 sconcat = pull . fmap sconcat . mapM sample

@@ -624,22 +566,25 @@ instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

624 times1p n = fmap $ times1p n

566 times1p n = fmap $ times1p n

625#endif

567#endif

626

568

569+-- | Alias for 'mapMaybe'

570+fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b

571+fmapMaybe = mapMaybe

572+

627−-- | Flipped version of 'fmapMaybe'.

573+-- | Flipped version of 'mapMaybe'.

628−fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b

574+fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b

629−fforMaybe = flip fmapMaybe

575+fforMaybe = flip mapMaybe

630

576

631-- | Filter 'f a' using the provided predicate.

577-- | Filter 'f a' using the provided predicate.

632−-- Relies on 'fforMaybe'.

633−ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a

578+ffilter :: Filterable f => (a -> Bool) -> f a -> f a

634−ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing

579+ffilter = W.filter

635

580

636-- | Filter 'Left's from 'f (Either a b)' into 'a'.

581-- | Filter 'Left's from 'f (Either a b)' into 'a'.

637−filterLeft :: FunctorMaybe f => f (Either a b) -> f a

582+filterLeft :: Filterable f => f (Either a b) -> f a

638−filterLeft = fmapMaybe (either Just (const Nothing))

583+filterLeft = mapMaybe (either Just (const Nothing))

639

584

640-- | Filter 'Right's from 'f (Either a b)' into 'b'.

585-- | Filter 'Right's from 'f (Either a b)' into 'b'.

641−filterRight :: FunctorMaybe f => f (Either a b) -> f b

586+filterRight :: Filterable f => f (Either a b) -> f b

642−filterRight = fmapMaybe (either (const Nothing) Just)

587+filterRight = mapMaybe (either (const Nothing) Just)

643

588

644-- | Left-biased event union (prefers left event on simultaneous

589-- | Left-biased event union (prefers left event on simultaneous

645-- occurrence).

590-- occurrence).

@@ -657,13 +602,18 @@ instance Reflex t => Bind (Event t) where

657

602

658instance Reflex t => Functor (Event t) where

603instance Reflex t => Functor (Event t) where

659 {-# INLINE fmap #-}

604 {-# INLINE fmap #-}

660− fmap f = fmapMaybe $ Just . f

605+ fmap f = mapMaybe $ Just . f

661 {-# INLINE (<$) #-}

606 {-# INLINE (<$) #-}

662 x <$ e = fmapCheap (const x) e

607 x <$ e = fmapCheap (const x) e

663

608

609+-- TODO Remove this instance

664instance Reflex t => FunctorMaybe (Event t) where

610instance Reflex t => FunctorMaybe (Event t) where

665 {-# INLINE fmapMaybe #-}

611 {-# INLINE fmapMaybe #-}

612+ fmapMaybe = mapMaybe

613+

614+instance Reflex t => Filterable (Event t) where

615+ {-# INLINE mapMaybe #-}

666− fmapMaybe f = push $ return . f

616+ mapMaybe f = push $ return . f

667

617

668-- | Never: @'zero' = 'never'@.

618-- | Never: @'zero' = 'never'@.

669instance Reflex t => Plus (Event t) where

619instance Reflex t => Plus (Event t) where

@@ -674,7 +624,13 @@ instance Reflex t => Plus (Event t) where

674tag :: Reflex t => Behavior t b -> Event t a -> Event t b

624tag :: Reflex t => Behavior t b -> Event t a -> Event t b

675tag b = pushAlways $ \_ -> sample b

625tag b = pushAlways $ \_ -> sample b

676

626

627+-- | Replace each occurrence value of the 'Event' with the value of the

628+-- 'Behavior' at that time; if it is 'Just', fire with the contained value; if

629+-- it is 'Nothing', drop the occurrence.

630+tagMaybe :: Reflex t => Behavior t (Maybe b) -> Event t a -> Event t b

631+tagMaybe b = push $ \_ -> sample b

632+

677−-- | Create a new 'Event' that combines occurences of supplied 'Event' with the

633+-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the

678-- current value of the 'Behavior'.

634-- current value of the 'Behavior'.

679attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

635attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

680attach = attachWith (,)

636attach = attachWith (,)

@@ -684,53 +640,118 @@ attach = attachWith (,)

684attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

640attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

685attachWith f = attachWithMaybe $ \a b -> Just $ f a b

641attachWith f = attachWithMaybe $ \a b -> Just $ f a b

686

642

687−-- | Create a new 'Event' by combining each occurence with the current value of

643+-- | Create a new 'Event' by combining each occurrence with the current value of

688-- the 'Behavior'. The occurrence is discarded if the combining function returns

644-- the 'Behavior'. The occurrence is discarded if the combining function returns

689-- Nothing

645-- Nothing

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

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

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

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

692

648

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

649+-- | Create a new 'Event' that occurs on all but the first occurrence of the

694-- supplied 'Event'.

650-- supplied 'Event'.

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

651+tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a)

696tailE e = snd <$> headTailE e

652tailE e = snd <$> headTailE e

697

653

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

654+-- | Create a tuple of two 'Event's with the first one occurring only the first

699−-- time the supplied 'Event' occurs and the second occuring on all but the first

655+-- time the supplied 'Event' occurs and the second occurring on all but the first

700−-- occurence.

656+-- occurrence.

701−headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)

657+headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)

702headTailE e = do

658headTailE e = do

703 eHead <- headE e

659 eHead <- headE e

704 be <- hold never $ fmap (const e) eHead

660 be <- hold never $ fmap (const e) eHead

705 return (eHead, switch be)

661 return (eHead, switch be)

706

662

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

664+-- event returns 'True'.

665+--

707−-- | Starting at the current time, fire all the occurrences of the 'Event' for

666+-- Starting at the current time, fire all the occurrences of the 'Event' for

708−-- which the given predicate returns 'True'. When 'False' is returned, do not

667+-- which the given predicate returns 'True'. When first 'False' is returned,

709−-- fire, and permanently stop firing, even if 'True' values are encountered

668+-- do not fire, and permanently stop firing, even if 'True' values would have

710−-- later.

669+-- been encountered later.

670+takeWhileE

671+ :: forall t m a

711−takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)

672+ . (Reflex t, MonadFix m, MonadHold t m)

712−takeWhileE f e = do

673+ => (a -> Bool)

674+ -> Event t a

675+ -> m (Event t a)

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

677+

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

679+-- event returns 'Just b'.

680+--

681+-- Starting at the current time, fire all the occurrences of the 'Event' for

682+-- which the given predicate returns 'Just b'. When first 'Nothing' is returned,

683+-- do not fire, and permanently stop firing, even if 'Just b' values would have

684+-- been encountered later.

685+takeWhileJustE

686+ :: forall t m a b

687+ . (Reflex t, MonadFix m, MonadHold t m)

688+ => (a -> Maybe b)

689+ -> Event t a

690+ -> m (Event t b)

691+takeWhileJustE f e = do

713− rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a

692+ rec let (eBad, eTrue) = fanEither $ ffor e' $ \a -> case f a of

714− then Right a

715− else Left never

693+ Nothing -> Left never

716− be <- hold e eFalse

694+ Just b -> Right b

717− let e' = switch be

695+ eFirstBad <- headE eBad

696+ e' <- switchHold e eFirstBad

718 return eTrue

697 return eTrue

719

698

699+-- | Drop the streak of occurrences starting at the current time for which the

700+-- event returns 'True'.

701+--

702+-- Starting at the current time, do not fire all the occurrences of the 'Event'

703+-- for which the given predicate returns 'True'. When 'False' is first

704+-- returned, do fire, and permanently continue firing, even if 'True' values

705+-- would have been encountered later.

706+dropWhileE

707+ :: forall t m a

708+ . (Reflex t, MonadFix m, MonadHold t m)

709+ => (a -> Bool)

710+ -> Event t a

711+ -> m (Event t a)

712+dropWhileE f e = snd <$> takeDropWhileJustE (\v -> guard (f v) $> v) e

713+

714+-- | Both take and drop the streak of occurrences starting at the current time

715+-- for which the event returns 'Just b'.

716+--

717+-- For the left event, starting at the current time, fire all the occurrences

718+-- of the 'Event' for which the given function returns 'Just b'. When

719+-- 'Nothing' is returned, do not fire, and permanently stop firing, even if

720+-- 'Just b' values would have been encountered later.

721+--

722+-- For the right event, do not fire until the first occurrence where the given

723+-- function returns 'Nothing', and fire that one and all subsequent

724+-- occurrences. Even if the function would have again returned 'Just b', keep

725+-- on firing.

726+takeDropWhileJustE

727+ :: forall t m a b

728+ . (Reflex t, MonadFix m, MonadHold t m)

729+ => (a -> Maybe b)

730+ -> Event t a

731+ -> m (Event t b, Event t a)

732+takeDropWhileJustE f e = do

733+ rec let (eBad, eGood) = fanEither $ ffor e' $ \a -> case f a of

734+ Nothing -> Left ()

735+ Just b -> Right b

736+ eFirstBad <- headE eBad

737+ e' <- switchHold e (never <$ eFirstBad)

738+ eRest <- switchHoldPromptOnly never (e <$ eFirstBad)

739+ return (eGood, eRest)

740+

720−-- | Split the supplied 'Event' into two individual 'Event's occuring at the

741+-- | Split the supplied 'Event' into two individual 'Event's occurring at the

721-- same time with the respective values from the tuple.

742-- same time with the respective values from the tuple.

722splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

743splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

723splitE e = (fmap fst e, fmap snd e)

744splitE e = (fmap fst e, fmap snd e)

724

745

725-- | Print the supplied 'String' and the value of the 'Event' on each

746-- | Print the supplied 'String' and the value of the 'Event' on each

726−-- occurence. This should /only/ be used for debugging.

747+-- occurrence. This should /only/ be used for debugging.

727--

748--

728-- Note: As with Debug.Trace.trace, the message will only be printed if the

749-- Note: As with Debug.Trace.trace, the message will only be printed if the

729-- 'Event' is actually used.

750-- 'Event' is actually used.

730traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

751traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

731traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

752traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

732

753

733−-- | Print the output of the supplied function on each occurence of the

754+-- | Print the output of the supplied function on each occurrence of the

734-- 'Event'. This should /only/ be used for debugging.

755-- 'Event'. This should /only/ be used for debugging.

735--

756--

736-- Note: As with Debug.Trace.trace, the message will only be printed if the

757-- Note: As with Debug.Trace.trace, the message will only be printed if the

@@ -774,7 +795,7 @@ leftmost :: Reflex t => [Event t a] -> Event t a

774leftmost = mergeWith const

795leftmost = mergeWith const

775

796

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

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

777−-- list occurs and has a list of the values of all 'Event's occuring at that

798+-- list occurs and has a list of the values of all 'Event's occurring at that

778-- time.

799-- time.

779mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

800mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

780mergeList [] = never

801mergeList [] = never

@@ -785,10 +806,14 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn

785

806

786-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

807-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

787-- occurs if at least one of them occurs and has a map of values of all 'Event's

808-- occurs if at least one of them occurs and has a map of values of all 'Event's

788−-- occuring at that time.

809+-- occurring at that time.

789mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

810mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

790mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

811mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

791

812

813+-- | Like 'mergeMap' but for 'IntMap'.

814+mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

815+mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap

816+

792-- | Create a merge whose parents can change over time

817-- | Create a merge whose parents can change over time

793mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

818mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

794mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

819mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

@@ -806,7 +831,7 @@ fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)

806fanEither e =

831fanEither e =

807 let justLeft = either Just (const Nothing)

832 let justLeft = either Just (const Nothing)

808 justRight = either (const Nothing) Just

833 justRight = either (const Nothing) Just

809− in (fmapMaybe justLeft e, fmapMaybe justRight e)

834+ in (mapMaybe justLeft e, mapMaybe justRight e)

810

835

811-- | Split the event into separate events for 'This' and 'That' values,

836-- | Split the event into separate events for 'This' and 'That' values,

812-- allowing them to fire simultaneously when the input value is 'These'.

837-- allowing them to fire simultaneously when the input value is 'These'.

@@ -818,43 +843,114 @@ fanThese e =

818 that (That y) = Just y

843 that (That y) = Just y

819 that (These _ y) = Just y

844 that (These _ y) = Just y

820 that _ = Nothing

845 that _ = Nothing

821− in (fmapMaybe this e, fmapMaybe that e)

846+ in (mapMaybe this e, mapMaybe that e)

822

847

823-- | Split the event into an 'EventSelector' that allows efficient selection of

848-- | Split the event into an 'EventSelector' that allows efficient selection of

824-- the individual 'Event's.

849-- the individual 'Event's.

825fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

850fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

826fanMap = fan . fmap mapToDMap

851fanMap = fan . fmap mapToDMap

827

852

828−-- | Switches to the new event whenever it receives one. Whenever a new event

853+-- | Switches to the new event whenever it receives one. Only the old event is

854+-- considered the moment a new one is switched in; the output event will fire at

855+-- that moment only if the old event does.

856+--

857+-- Because the simultaneous firing case is irrelevant, this function imposes

858+-- laxer "timing requirements" on the overall circuit, avoiding many potential

859+-- cyclic dependency / metastability failures. It's also more performant. Use

860+-- this rather than 'switchHoldPromptly' and 'switchHoldPromptOnly' unless you

861+-- are absolutely sure you need to act on the new event in the coincidental

862+-- case.

863+switchHold :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

864+switchHold ea0 eea = switch <$> hold ea0 eea

865+

866+-- | Switches to the new event whenever it receives one. Whenever a new event is

829−-- is provided, if it is firing, its value will be the resulting event's value;

867+-- provided, if it is firing, its value will be the resulting event's value; if

830−-- if it is not firing, but the old one is, the old one's value will be used.

868+-- it is not firing, but the old one is, the old one's value will be used.

869+--

870+-- 'switchHold', by always forwarding the old event the moment it is switched

871+-- out, avoids many potential cyclic dependency problems / metastability

872+-- problems. It's also more performant. Use it instead unless you are sure you

873+-- cannot.

831−switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

874+switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

832−switchPromptly ea0 eea = do

875+switchHoldPromptly ea0 eea = do

833 bea <- hold ea0 eea

876 bea <- hold ea0 eea

834 let eLag = switch bea

877 let eLag = switch bea

835 eCoincidences = coincidence eea

878 eCoincidences = coincidence eea

836 return $ leftmost [eCoincidences, eLag]

879 return $ leftmost [eCoincidences, eLag]

837

880

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

881+-- | switches to a new event whenever it receives one. At the moment of

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

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

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

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

841-- old value.

884-- old value.

885+--

886+-- 'switchHold', by always forwarding the old event the moment it is switched

887+-- out, avoids many potential cyclic dependency problems / metastability

888+-- problems. It's also more performant. Use it instead unless you are sure you

889+-- cannot.

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

890+switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

843−switchPromptOnly e0 e' = do

891+switchHoldPromptOnly e0 e' = do

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

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

845 return $ coincidence $ leftmost [e', eLag <$ eLag]

893 return $ coincidence $ leftmost [e', eLag <$ eLag]

846

894

895+-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.

896+coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)

897+coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case

898+ Nothing -> fmapCheap (const Nothing) e

899+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

900+

901+-- | See 'coincidencePatchMap'

902+coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)

903+coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case

904+ Nothing -> fmapCheap (const Nothing) e

905+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

906+

907+-- | See 'coincidencePatchMap'

908+coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)

909+coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of

910+ PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->

911+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

912+ PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->

913+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }

914+ PatchMapWithMove.From_Insert ev -> leftmost

915+ [ fforCheap ev $ \v ->

916+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }

917+ , fforCheap e $ \_ ->

918+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

919+ ]

920+

921+switchHoldPromptOnlyIncremental

922+ :: forall t m p pt w

923+ . ( Reflex t

924+ , MonadHold t m

925+ , Patch (p (Event t w))

926+ , PatchTarget (p (Event t w)) ~ pt (Event t w)

927+ , Patch (p w)

928+ , PatchTarget (p w) ~ pt w

929+ , Monoid (pt w)

930+ )

931+ => (Incremental t (p (Event t w)) -> Event t (pt w))

932+ -> (Event t (p (Event t w)) -> Event t (p w))

933+ -> pt (Event t w)

934+ -> Event t (p (Event t w))

935+ -> m (Event t (pt w))

936+switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do

937+ lag <- mergePatchIncremental <$> holdIncremental e0 e'

938+ pure $ ffor (align lag (coincidencePatch e')) $ \case

939+ This old -> old

940+ That new -> new `applyAlways` mempty

941+ These old new -> new `applyAlways` old

942+

847instance Reflex t => Align (Event t) where

943instance Reflex t => Align (Event t) where

848 nil = never

944 nil = never

849 align = alignEventWithMaybe Just

945 align = alignEventWithMaybe Just

850

946

851-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and

947-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and

852−-- the 'Behavior' is true at the time of occurence.

948+-- the 'Behavior' is true at the time of occurrence.

853gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

949gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

854gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

950gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

855

951

856−-- | Create a new behavior given a starting behavior and switch to a the behvior

952+-- | Create a new behavior given a starting behavior and switch to the behavior

857−-- carried by the event when it fires.

953+-- carried by the event when it fires.

858switcher :: (Reflex t, MonadHold t m)

954switcher :: (Reflex t, MonadHold t m)

859 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

955 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

860switcher b eb = pull . (sample <=< sample) <$> hold b eb

956switcher b eb = pull . (sample <=< sample) <$> hold b eb

@@ -869,7 +965,7 @@ zipDyn = zipDynWith (,)

869

965

870-- | Combine two 'Dynamic's with a combining function. The result will change

966-- | Combine two 'Dynamic's with a combining function. The result will change

871-- whenever either (or both) input 'Dynamic' changes.

967-- whenever either (or both) input 'Dynamic' changes.

872−-- More efficient than liftA2.

968+-- More efficient than 'liftA2'.

873zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

969zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

874zipDynWith f da db =

970zipDynWith f da db =

875 let eab = align (updated da) (updated db)

971 let eab = align (updated da) (updated db)

@@ -885,6 +981,14 @@ zipDynWith f da db =

885 return $ Just $ f a b

981 return $ Just $ f a b

886 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

982 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

887

983

984+instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where

985+ (<>) = zipDynWith (<>)

986+#if MIN_VERSION_semigroups(0,17,0)

987+ stimes n = fmap $ stimes n

988+#else

989+ times1p n = fmap $ times1p n

990+#endif

991+

888instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

992instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

889 mconcat = distributeListOverDynWith mconcat

993 mconcat = distributeListOverDynWith mconcat

890 mempty = constDyn mempty

994 mempty = constDyn mempty

@@ -892,7 +996,7 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

892

996

893-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

997-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

894-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

998-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

895−-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.

999+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

896distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

1000distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

897distributeDMapOverDynPure dm = case DMap.toList dm of

1001distributeDMapOverDynPure dm = case DMap.toList dm of

898 [] -> constDyn DMap.empty

1002 [] -> constDyn DMap.empty

@@ -918,14 +1022,57 @@ distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) .

918difference :: Reflex t => Event t a -> Event t b -> Event t a

1022difference :: Reflex t => Event t a -> Event t b -> Event t a

919difference = alignEventWithMaybe $ \case

1023difference = alignEventWithMaybe $ \case

920 This a -> Just a

1024 This a -> Just a

921− _ -> Nothing

1025+ _ -> Nothing

922

1026

1027+-- | Zips two values by taking the union of their shapes and combining with the provided function.

1028+-- 'Nothing' values are dropped.

923alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c

1029alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c

924−alignEventWithMaybe f ea eb =

1030+alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $

925− fmapMaybe (f <=< dmapToThese)

926− $ merge

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

1031+ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

928−

1032+

1033+-- | Produces an 'Event' that fires only when the input event fires with a 'DSum' key that

1034+-- matches the provided key.

1035+filterEventKey

1036+ :: forall t m k v a.

1037+ ( Reflex t

1038+ , MonadFix m

1039+ , MonadHold t m

1040+ , GEq k

1041+ )

1042+ => k a

1043+ -> Event t (DSum k v)

1044+ -> m (Event t (v a))

1045+filterEventKey k kv' = do

1046+ let f :: DSum k v -> Maybe (v a)

1047+ f (newK :=> newV) = case newK `geq` k of

1048+ Just Refl -> Just newV

1049+ Nothing -> Nothing

1050+ takeWhileJustE f kv'

1051+

1052+-- | "Factor" the input 'DSum' 'Event' to produce an 'Event' which

1053+-- fires when the 'DSum' key changes and contains both the value of the

1054+-- 'DSum' at switchover and an 'Event' of values produced by subsequent

1055+-- firings of the input 'Event' that do not change the 'DSum' key.

1056+factorEvent

1057+ :: forall t m k v a.

1058+ ( Reflex t

1059+ , MonadFix m

1060+ , MonadHold t m

1061+ , GEq k

1062+ )

1063+ => k a

1064+ -> Event t (DSum k v)

1065+ -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))

1066+factorEvent k0 kv' = do

1067+ key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv'

1068+ let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case

1069+ Some.This oldKey -> case newKey `geq` oldKey of

1070+ Just Refl -> return Nothing

1071+ Nothing -> do

1072+ newInner <- filterEventKey newKey kv'

1073+ return $ Just $ newKey :=> Pair newVal (Compose newInner)

1074+ eInitial <- filterEventKey k0 kv'

1075+ return (eInitial, update)

929

1076

930--------------------------------------------------------------------------------

1077--------------------------------------------------------------------------------

931-- Accumulator

1078-- Accumulator

@@ -955,26 +1102,94 @@ class Reflex t => Accumulator t f | f -> t where

955 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

1102 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

956 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)

1103 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)

957

1104

1105+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1106+-- with the provided function. See 'foldDyn'.

1107+accumDyn

958−accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)

1108+ :: (Reflex t, MonadHold t m, MonadFix m)

1109+ => (a -> b -> a)

1110+ -> a

1111+ -> Event t b

1112+ -> m (Dynamic t a)

959accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o

1113accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o

1114+

1115+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1116+-- with the provided 'PushM' action.

1117+accumMDyn

960−accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)

1118+ :: (Reflex t, MonadHold t m, MonadFix m)

1119+ => (a -> b -> PushM t a)

1120+ -> a

1121+ -> Event t b

1122+ -> m (Dynamic t a)

961accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o

1123accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o

1124+

1125+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1126+-- with the provided function, discarding 'Nothing' results.

1127+accumMaybeDyn

962−accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)

1128+ :: (Reflex t, MonadHold t m, MonadFix m)

1129+ => (a -> b -> Maybe a)

1130+ -> a

1131+ -> Event t b

1132+ -> m (Dynamic t a)

963accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o

1133accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o

1134+

1135+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1136+-- with the provided 'PushM' action, discarding 'Nothing' results.

1137+accumMaybeMDyn

964−accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)

1138+ :: (Reflex t, MonadHold t m, MonadFix m)

1139+ => (a -> b -> PushM t (Maybe a))

1140+ -> a

1141+ -> Event t b

1142+ -> m (Dynamic t a)

965accumMaybeMDyn f z e = do

1143accumMaybeMDyn f z e = do

966 rec let e' = flip push e $ \o -> do

1144 rec let e' = flip push e $ \o -> do

967 v <- sample $ current d'

1145 v <- sample $ current d'

968 f v o

1146 f v o

969 d' <- holdDyn z e'

1147 d' <- holdDyn z e'

970 return d'

1148 return d'

1149+

1150+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1151+-- with a function that both accumulates and produces a value to fire

1152+-- as an 'Event'. Returns both the accumulated value and an 'Event'.

1153+mapAccumDyn

971−mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

1154+ :: (Reflex t, MonadHold t m, MonadFix m)

1155+ => (a -> b -> (a, c))

1156+ -> a

1157+ -> Event t b

1158+ -> m (Dynamic t a, Event t c)

972mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o

1159mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o

1160+

1161+-- | Similar to 'mapAccumDyn' except that the combining function is a

1162+-- 'PushM' action.

1163+mapAccumMDyn

973−mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

1164+ :: (Reflex t, MonadHold t m, MonadFix m)

1165+ => (a -> b -> PushM t (a, c))

1166+ -> a

1167+ -> Event t b

1168+ -> m (Dynamic t a, Event t c)

974mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o

1169mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o

1170+

1171+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' with

1172+-- a function that both optionally accumulates and optionally produces

1173+-- a value to fire as a separate output 'Event'.

1174+-- Note that because 'Nothing's are discarded in both cases, the output

1175+-- 'Event' may fire even though the output 'Dynamic' has not changed, and

1176+-- the output 'Dynamic' may update even when the output 'Event' is not firing.

1177+mapAccumMaybeDyn

975−mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

1178+ :: (Reflex t, MonadHold t m, MonadFix m)

1179+ => (a -> b -> (Maybe a, Maybe c))

1180+ -> a

1181+ -> Event t b

1182+ -> m (Dynamic t a, Event t c)

976mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o

1183mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o

1184+

1185+-- | Like 'mapAccumMaybeDyn' except that the combining function is a

1186+-- 'PushM' action.

1187+mapAccumMaybeMDyn

977−mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

1188+ :: (Reflex t, MonadHold t m, MonadFix m)

1189+ => (a -> b -> PushM t (Maybe a, Maybe c))

1190+ -> a

1191+ -> Event t b

1192+ -> m (Dynamic t a, Event t c)

978mapAccumMaybeMDyn f z e = do

1193mapAccumMaybeMDyn f z e = do

979 rec let e' = flip push e $ \o -> do

1194 rec let e' = flip push e $ \o -> do

980 v <- sample $ current d'

1195 v <- sample $ current d'

@@ -982,18 +1197,42 @@ mapAccumMaybeMDyn f z e = do

982 return $ case result of

1197 return $ case result of

983 (Nothing, Nothing) -> Nothing

1198 (Nothing, Nothing) -> Nothing

984 _ -> Just result

1199 _ -> Just result

985− d' <- holdDyn z $ fmapMaybe fst e'

1200+ d' <- holdDyn z $ mapMaybe fst e'

986− return (d', fmapMaybe snd e')

1201+ return (d', mapMaybe snd e')

987

1202

1203+-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1204+-- with the provided function.

988{-# INLINE accumB #-}

1205{-# INLINE accumB #-}

1206+accumB

989−accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)

1207+ :: (Reflex t, MonadHold t m, MonadFix m)

1208+ => (a -> b -> a)

1209+ -> a

1210+ -> Event t b

1211+ -> m (Behavior t a)

990accumB f = accumMaybeB $ \v o -> Just $ f v o

1212accumB f = accumMaybeB $ \v o -> Just $ f v o

1213+

1214+-- | Like 'accumB' except that the combining function is a 'PushM' action.

991{-# INLINE accumMB #-}

1215{-# INLINE accumMB #-}

1216+accumMB

992−accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)

1217+ :: (Reflex t, MonadHold t m, MonadFix m)

1218+ => (a -> b -> PushM t a)

1219+ -> a

1220+ -> Event t b

1221+ -> m (Behavior t a)

993accumMB f = accumMaybeMB $ \v o -> Just <$> f v o

1222accumMB f = accumMaybeMB $ \v o -> Just <$> f v o

1223+

1224+-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1225+-- with the provided function, discarding 'Nothing' results.

994{-# INLINE accumMaybeB #-}

1226{-# INLINE accumMaybeB #-}

1227+accumMaybeB

995−accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)

1228+ :: (Reflex t, MonadHold t m, MonadFix m)

1229+ => (a -> b -> Maybe a)

1230+ -> a

1231+ -> Event t b

1232+ -> m (Behavior t a)

996accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o

1233accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o

1234+

1235+-- | Like 'accumMaybeB' except that the combining function is a 'PushM' action.

997{-# INLINE accumMaybeMB #-}

1236{-# INLINE accumMaybeMB #-}

998accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)

1237accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)

999accumMaybeMB f z e = do

1238accumMaybeMB f z e = do

@@ -1002,16 +1241,42 @@ accumMaybeMB f z e = do

1002 f v o

1241 f v o

1003 d' <- hold z e'

1242 d' <- hold z e'

1004 return d'

1243 return d'

1244+

1245+-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1246+-- with a function that both accumulates and produces a value to fire

1247+-- as an 'Event'. Returns both the accumulated value and an 'Event'.

1005{-# INLINE mapAccumB #-}

1248{-# INLINE mapAccumB #-}

1249+mapAccumB

1006−mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1250+ :: (Reflex t, MonadHold t m, MonadFix m)

1251+ => (a -> b -> (a, c))

1252+ -> a

1253+ -> Event t b

1254+ -> m (Behavior t a, Event t c)

1007mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o

1255mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o

1256+

1257+-- | Like 'mapAccumB' except that the combining function is a 'PushM' action.

1008{-# INLINE mapAccumMB #-}

1258{-# INLINE mapAccumMB #-}

1259+mapAccumMB

1009−mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1260+ :: (Reflex t, MonadHold t m, MonadFix m)

1261+ => (a -> b -> PushM t (a, c))

1262+ -> a

1263+ -> Event t b

1264+ -> m (Behavior t a, Event t c)

1010mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o

1265mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o

1266+

1267+-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' with

1268+-- a function that both optionally accumulates and optionally produces

1269+-- a value to fire as a separate output 'Event'. 'Nothing's are discarded.

1011{-# INLINE mapAccumMaybeB #-}

1270{-# INLINE mapAccumMaybeB #-}

1271+mapAccumMaybeB

1012−mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1272+ :: (Reflex t, MonadHold t m, MonadFix m)

1273+ => (a -> b -> (Maybe a, Maybe c))

1274+ -> a

1275+ -> Event t b

1276+ -> m (Behavior t a, Event t c)

1013mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o

1277mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o

1014

1278

1279+-- | LIke 'mapAccumMaybeB' except that the combining function is a 'PushM' action.

1015{-# INLINE mapAccumMaybeMB #-}

1280{-# INLINE mapAccumMaybeMB #-}

1016mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1281mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1017mapAccumMaybeMB f z e = do

1282mapAccumMaybeMB f z e = do

@@ -1021,8 +1286,8 @@ mapAccumMaybeMB f z e = do

1021 return $ case result of

1286 return $ case result of

1022 (Nothing, Nothing) -> Nothing

1287 (Nothing, Nothing) -> Nothing

1023 _ -> Just result

1288 _ -> Just result

1024− d' <- hold z $ fmapMaybe fst e'

1289+ d' <- hold z $ mapMaybe fst e'

1025− return (d', fmapMaybe snd e')

1290+ return (d', mapMaybe snd e')

1026

1291

1027-- | Accumulate occurrences of an 'Event', producing an output occurrence each

1292-- | Accumulate occurrences of an 'Event', producing an output occurrence each

1028-- time. Discard the underlying 'Accumulator'.

1293-- time. Discard the underlying 'Accumulator'.

@@ -1069,7 +1334,7 @@ instance Reflex t => Accumulator t (Event t) where

1069 accumMaybeM f z e = updated <$> accumMaybeM f z e

1334 accumMaybeM f z e = updated <$> accumMaybeM f z e

1070 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

1335 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

1071

1336

1072−-- | Create a new 'Event' by combining each occurence with the next value of the

1337+-- | Create a new 'Event' by combining each occurrence with the next value of the

1073-- list using the supplied function. If the list runs out of items, all

1338-- list using the supplied function. If the list runs out of items, all

1074-- subsequent 'Event' occurrences will be ignored.

1339-- subsequent 'Event' occurrences will be ignored.

1075zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)

1340zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)

@@ -1079,20 +1344,20 @@ zipListWithEvent f l e = do

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

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

1080 mapAccumMaybe_ f' l e

1345 mapAccumMaybe_ f' l e

1081

1346

1082−-- | Assign a number to each occurence of the given 'Event', starting from 0

1347+-- | Assign a number to each occurrence of the given 'Event', starting from 0

1083{-# INLINE numberOccurrences #-}

1348{-# INLINE numberOccurrences #-}

1084numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

1349numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

1085numberOccurrences = numberOccurrencesFrom 0

1350numberOccurrences = numberOccurrencesFrom 0

1086

1351

1087−-- | Assign a number to each occurence of the given 'Event'

1352+-- | Assign a number to each occurrence of the given 'Event'

1088{-# INLINE numberOccurrencesFrom #-}

1353{-# INLINE numberOccurrencesFrom #-}

1089numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))

1354numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))

1090−numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))

1355+numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))

1091

1356

1092−-- | Assign a number to each occurence of the given 'Event'; discard the occurrences' values

1357+-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values

1093{-# INLINE numberOccurrencesFrom_ #-}

1358{-# INLINE numberOccurrencesFrom_ #-}

1094numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)

1359numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)

1095−numberOccurrencesFrom_ = mapAccum_ (\n _ -> (n + 1, n))

1360+numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))

1096

1361

1097-- | This is used to sample the value of a 'Behavior' using an 'Event'.

1362-- | This is used to sample the value of a 'Behavior' using an 'Event'.

1098--

1363--

@@ -1162,83 +1427,57 @@ infixl 4 <@>

1162(<@) = tag

1427(<@) = tag

1163infixl 4 <@

1428infixl 4 <@

1164

1429

1165−------------------

1166−-- Adjustable

1167−------------------

1168−

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

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

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

1172−-- is some issue here with persistent side-effects: obviously, IO (and some

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

1174−-- to determine what the best meaning for this class is in such cases.

1175−class (Reflex t, Monad m) => Adjustable t m | m -> t where

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

1177− traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))

1178− traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))

1179− traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))

1180−

1181−instance Adjustable t m => Adjustable t (ReaderT r m) where

1182− runWithReplace a0 a' = do

1183− r <- ask

1184− lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1185− traverseIntMapWithKeyWithAdjust f dm0 dm' = do

1186− r <- ask

1187− lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

1188− traverseDMapWithKeyWithAdjust f dm0 dm' = do

1189− r <- ask

1190− lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

1191− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

1192− r <- ask

1193− lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'

1194−

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

1196−sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity

1197−

1198−sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))

1199−sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity

1200−

1201−mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))

1202−mapMapWithAdjustWithMove f m0 m' = do

1203− (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

1204− return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

1205−

1206------------------

1430------------------

1207-- Cheap Functions

1431-- Cheap Functions

1208------------------

1432------------------

1209

1433

1434+-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'.

1210{-# INLINE pushAlwaysCheap #-}

1435{-# INLINE pushAlwaysCheap #-}

1211pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

1436pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

1212pushAlwaysCheap f = pushCheap (fmap Just . f)

1437pushAlwaysCheap f = pushCheap (fmap Just . f)

1213

1438

1439+-- | A "cheap" version of 'mapMaybe'. See the performance note on 'pushCheap'.

1440+{-# INLINE mapMaybeCheap #-}

1441+mapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1442+mapMaybeCheap f = pushCheap $ return . f

1443+

1444+-- | An alias for 'mapMaybeCheap'

1214{-# INLINE fmapMaybeCheap #-}

1445{-# INLINE fmapMaybeCheap #-}

1215fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1446fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1216−fmapMaybeCheap f = pushCheap $ return . f

1447+fmapMaybeCheap = mapMaybeCheap

1217

1448

1449+

1450+-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'.

1218{-# INLINE fforMaybeCheap #-}

1451{-# INLINE fforMaybeCheap #-}

1219fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

1452fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

1220−fforMaybeCheap = flip fmapMaybeCheap

1453+fforMaybeCheap = flip mapMaybeCheap

1221

1454

1455+-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'.

1222{-# INLINE fforCheap #-}

1456{-# INLINE fforCheap #-}

1223fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

1457fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

1224fforCheap = flip fmapCheap

1458fforCheap = flip fmapCheap

1225

1459

1460+-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'.

1226{-# INLINE fmapCheap #-}

1461{-# INLINE fmapCheap #-}

1227fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

1462fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

1228fmapCheap f = pushCheap $ return . Just . f

1463fmapCheap f = pushCheap $ return . Just . f

1229

1464

1465+-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'.

1230{-# INLINE tagCheap #-}

1466{-# INLINE tagCheap #-}

1231tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

1467tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

1232tagCheap b = pushAlwaysCheap $ \_ -> sample b

1468tagCheap b = pushAlwaysCheap $ \_ -> sample b

1233

1469

1470+-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

1234{-# INLINE mergeWithCheap #-}

1471{-# INLINE mergeWithCheap #-}

1235mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

1472mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

1236mergeWithCheap = mergeWithCheap' id

1473mergeWithCheap = mergeWithCheap' id

1237

1474

1475+-- | A "cheap" version of 'mergeWithCheap''. See the performance note on 'pushCheap'.

1238{-# INLINE mergeWithCheap' #-}

1476{-# INLINE mergeWithCheap' #-}

1239mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

1477mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

1240mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

1478mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

1241

1479

1480+-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.

1242{-# INLINE mergeWithFoldCheap' #-}

1481{-# INLINE mergeWithFoldCheap' #-}

1243mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1482mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1244mergeWithFoldCheap' f es =

1483mergeWithFoldCheap' f es =

@@ -1251,27 +1490,9 @@ mergeWithFoldCheap' f es =

1251-- Deprecated functions

1490-- Deprecated functions

1252--------------------------------------------------------------------------------

1491--------------------------------------------------------------------------------

1253

1492

1254−{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}

1493+{-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}

1255−type MonadAdjust = Adjustable

1256−

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

1258−-- occurs. If both occur at the same time they are combined using 'mappend'.

1259−{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}

1260−appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a

1494+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1261−appendEvents = alignWith $ mergeThese mappend

1495+switchPromptly = switchHoldPromptly

1262−

1496+{-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}

1263−-- | Alias for 'headE'

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

1264−{-# DEPRECATED onceE "Use 'headE' instead" #-}

1498+switchPromptOnly = switchHoldPromptOnly

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

1266−onceE = headE

1267−

1268−-- | Run both sides of a 'These' monadically, combining the results.

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

1270−#ifdef USE_TEMPLATE_HASKELL

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

1272−#endif

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

1274−sequenceThese t = case t of

1275− This ma -> fmap This ma

1276− These ma mb -> liftM2 These ma mb

1277− That mb -> fmap That mb

src/Reflex/Collection.hs+157−60

@@ -1,22 +1,23 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RecursiveDo #-}

6{-# LANGUAGE RecursiveDo #-}

5{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

9{-# LANGUAGE UndecidableInstances #-}

11#ifdef USE_REFLEX_OPTIMIZER

10#ifdef USE_REFLEX_OPTIMIZER

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

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

13#endif

12#endif

13+-- |

14+-- Module:

15+-- Reflex.Collection

14module Reflex.Collection

16module Reflex.Collection

15− (

17+ (

16 -- * Widgets on Collections

18 -- * Widgets on Collections

17 listHoldWithKey

19 listHoldWithKey

18 , listWithKey

20 , listWithKey

19− , listWithKey'

20 , listWithKeyShallowDiff

21 , listWithKeyShallowDiff

21 , listViewWithKey

22 , listViewWithKey

22 , selectViewListWithKey

23 , selectViewListWithKey

@@ -26,96 +27,192 @@ module Reflex.Collection

26 , simpleList

27 , simpleList

27 ) where

28 ) where

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

30+import Control.Monad.Identity

30import Data.Align

31import Data.Align

32+import Data.Functor.Misc

31import Data.Map (Map)

33import Data.Map (Map)

32import qualified Data.Map as Map

34import qualified Data.Map as Map

33−import Data.Functor.Misc

34import Data.Map.Misc

35import Data.Map.Misc

35import Data.These

36import Data.These

37import Reflex.Class

38import Reflex.Class

39+import Reflex.Adjustable.Class

38import Reflex.Dynamic

40import Reflex.Dynamic

39import Reflex.PostBuild.Class

41import Reflex.PostBuild.Class

43+-- | Create a set of widgets based on the provided 'Map'. When the

44+-- input 'Event' fires, remove widgets for keys with the value 'Nothing'

45+-- and add/replace widgets for keys with 'Just' values.

46+listHoldWithKey

47+ :: forall t m k v a

41−listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))

48+ . (Ord k, Adjustable t m, MonadHold t m)

49+ => Map k v

50+ -> Event t (Map k (Maybe v))

51+ -> (k -> v -> m a)

52+ -> m (Dynamic t (Map k a))

42listHoldWithKey m0 m' f = do

53listHoldWithKey m0 m' f = do

43 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

54 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

55+ dm' = fmap

44− dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'

56+ (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey

57+ (\k v -> ComposeMaybe $ fmap (f k) v)

58+ )

59+ m'

45 (a0, a') <- sequenceDMapWithAdjust dm0 dm'

60 (a0, a') <- sequenceDMapWithAdjust dm0 dm'

46− fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time

62+ --TODO: Move the dmapToMap to the righthand side so it doesn't get

63+ --fully redone every time

64+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'

65+

48−--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

66+--TODO: Something better than Dynamic t (Map k v) - we want something

67+--where the Events carry diffs, not the whole value

68+listWithKey

69+ :: forall t k v m a

49−listWithKey :: forall t k v m a. (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

70+ . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)

71+ => Dynamic t (Map k v)

72+ -> (k -> Dynamic t v -> m a)

73+ -> m (Dynamic t (Map k a))

50listWithKey vals mkChild = do

74listWithKey vals mkChild = do

51 postBuild <- getPostBuild

75 postBuild <- getPostBuild

52 let childValChangedSelector = fanMap $ updated vals

76 let childValChangedSelector = fanMap $ updated vals

77+

53− -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey

78+ -- We keep track of changes to children values in the mkChild

79+ -- function we pass to listHoldWithKey The other changes we need

54− -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges

80+ -- to keep track of are child insertions and

81+ -- deletions. diffOnlyKeyChanges keeps track of insertions and

55− -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.

82+ -- deletions but ignores value changes, since they're already

83+ -- accounted for.

84+ diffOnlyKeyChanges olds news =

56− diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case

85+ flip Map.mapMaybe (align olds news) $ \case

57− This _ -> Just Nothing

86+ This _ -> Just Nothing

58− These _ _ -> Nothing

87+ These _ _ -> Nothing

59− That new -> Just $ Just new

88+ That new -> Just $ Just new

60 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals

89 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals

61 let changeVals :: Event t (Map k (Maybe v))

90 let changeVals :: Event t (Map k (Maybe v))

91+ changeVals =

62− changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost

92+ attachWith diffOnlyKeyChanges (current sentVals) $ leftmost

63− [ updated vals

93+ [ updated vals

94+

95+ -- TODO: This should probably be added to the

96+ -- attachWith, not to the updated; if we were using

64− , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work

97+ -- diffMap instead of diffMapNoEq, I think it might not

98+ -- work

99+ , tag (current vals) postBuild

65− ]

100+ ]

66 listHoldWithKey Map.empty changeVals $ \k v ->

101 listHoldWithKey Map.empty changeVals $ \k v ->

67 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)

102 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)

103

69−{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}

104+-- | Display the given map of items (in key order) using the builder

70−listWithKey' :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

105+-- function provided, and update it with the given event. 'Nothing'

71−listWithKey' = listWithKeyShallowDiff

106+-- update entries will delete the corresponding children, and 'Just'

72−

107+-- entries will create them if they do not exist or send an update

73−-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.

108+-- event to them if they do.

109+listWithKeyShallowDiff

74−listWithKeyShallowDiff :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

110+ :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)

111+ => Map k v

112+ -> Event t (Map k (Maybe v))

113+ -> (k -> v -> Event t v -> m a)

114+ -> m (Dynamic t (Map k a))

75listWithKeyShallowDiff initialVals valsChanged mkChild = do

115listWithKeyShallowDiff initialVals valsChanged mkChild = do

76 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged

116 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged

77 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged

117 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged

78 let relevantPatch patch _ = case patch of

118 let relevantPatch patch _ = case patch of

119+

79− Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored

120+ -- Even if we let a Nothing through when the element doesn't

121+ -- already exist, this doesn't cause a problem because it is

122+ -- ignored

123+ Nothing -> Just Nothing

124+

80− Just _ -> Nothing -- We don't want to let spurious re-creations of items through

125+ -- We don't want to let spurious re-creations of items through

126+ Just _ -> Nothing

127+ listHoldWithKey

128+ initialVals

81− listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->

129+ (attachWith (flip (Map.differenceWith relevantPatch))

130+ (current sentVals)

131+ valsChanged

132+ )

82− mkChild k v $ select childValChangedSelector $ Const2 k

133+ $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k

83−

134+

84−--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

135+--TODO: Something better than Dynamic t (Map k v) - we want something

136+--where the Events carry diffs, not the whole value

85−-- | Create a dynamically-changing set of Event-valued widgets.

137+-- | Create a dynamically-changing set of Event-valued widgets. This

86−-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.

138+-- is like 'listWithKey', specialized for widgets returning @/Event t a/@.

139+-- 'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in

140+-- this scenario, but 'listViewWithKey' flattens this to

141+-- @/Event t (Map k a)/@ via 'switch'.

142+listViewWithKey

87−listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))

143+ :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)

144+ => Dynamic t (Map k v)

145+ -> (k -> Dynamic t v -> m (Event t a))

146+ -> m (Event t (Map k a))

147+listViewWithKey vals mkChild =

88−listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild

148+ switch . fmap mergeMap <$> listViewWithKey' vals mkChild

89−

149+

150+listViewWithKey'

90−listViewWithKey' :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

151+ :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)

152+ => Dynamic t (Map k v)

153+ -> (k -> Dynamic t v -> m a)

154+ -> m (Behavior t (Map k a))

91listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

155listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

156

93−-- | Create a dynamically-changing set of widgets, one of which is selected at any time.

157+-- | Create a dynamically-changing set of widgets, one of which is

158+-- selected at any time.

159+selectViewListWithKey

160+ :: forall t m k v a

94−selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

161+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

162+ => Dynamic t k

95− => Dynamic t k -- ^ Current selection key

163+ -- ^ Current selection key

164+ -> Dynamic t (Map k v)

96− -> Dynamic t (Map k v) -- ^ Dynamic key/value map

165+ -- ^ Dynamic key/value map

166+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))

167+ -- ^ Function to create a widget for a given key from Dynamic value

97− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

168+ -- and Dynamic Bool indicating if this widget is currently selected

169+ -> m (Event t (k, a))

98− -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

170+ -- ^ Event that fires when any child's return Event fires. Contains

171+ -- key of an arbitrary firing widget.

99selectViewListWithKey selection vals mkChild = do

172selectViewListWithKey selection vals mkChild = do

100− let selectionDemux = demux selection -- For good performance, this value must be shared across all children

173+ -- For good performance, this value must be shared across all children

174+ let selectionDemux = demux selection

101 selectChild <- listWithKey vals $ \k v -> do

175 selectChild <- listWithKey vals $ \k v -> do

102 let selected = demuxed selectionDemux k

176 let selected = demuxed selectionDemux k

103 selectSelf <- mkChild k v selected

177 selectSelf <- mkChild k v selected

104 return $ fmap ((,) k) selectSelf

178 return $ fmap ((,) k) selectSelf

105 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

179 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

106

180

181+-- | Like 'selectViewListWithKey' but discards the value of the list

182+-- item widget's output 'Event'.

183+selectViewListWithKey_

184+ :: forall t m k v a

107−selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

185+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

186+ => Dynamic t k

108− => Dynamic t k -- ^ Current selection key

187+ -- ^ Current selection key

188+ -> Dynamic t (Map k v)

109− -> Dynamic t (Map k v) -- ^ Dynamic key/value map

189+ -- ^ Dynamic key/value map

190+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))

191+ -- ^ Function to create a widget for a given key from Dynamic value

110− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

192+ -- and Dynamic Bool indicating if this widget is currently selected

193+ -> m (Event t k)

111− -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

194+ -- ^ Event that fires when any child's return Event fires. Contains

195+ -- key of an arbitrary firing widget.

196+selectViewListWithKey_ selection vals mkChild =

112−selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

197+ fmap fst <$> selectViewListWithKey selection vals mkChild

113

198

114−-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.

199+-- | Create a dynamically-changing set of widgets from a Dynamic

200+-- key/value map. Unlike the 'withKey' variants, the child widgets

115−-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.

201+-- are insensitive to which key they're associated with.

202+list

116−list :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))

203+ :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)

204+ => Dynamic t (Map k v)

205+ -> (Dynamic t v -> m a)

206+ -> m (Dynamic t (Map k a))

117list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

207list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

118

208

119-- | Create a dynamically-changing set of widgets from a Dynamic list.

209-- | Create a dynamically-changing set of widgets from a Dynamic list.

210+simpleList

120−simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])

211+ :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)

212+ => Dynamic t [v]

213+ -> (Dynamic t v -> m a)

214+ -> m (Dynamic t [a])

215+simpleList xs mkChild =

121−simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs

216+ fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap

217+ (Map.fromList . zip [(1 :: Int) ..])

218+ xs

src/Reflex/Dynamic.hs+60−208

@@ -17,8 +17,12 @@

17#ifdef USE_REFLEX_OPTIMIZER

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

19#endif

20+-- |

21+-- Module:

22+-- Reflex.Dynamic

23+-- Description:

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

24+-- This module contains various functions for working with 'Dynamic' values.

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

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

22module Reflex.Dynamic

26module Reflex.Dynamic

23 ( -- * Basics

27 ( -- * Basics

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

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

@@ -30,6 +34,7 @@ module Reflex.Dynamic

30 , constDyn

34 , constDyn

31 , count

35 , count

32 , toggle

36 , toggle

37+ , switchDyn

33 , switchPromptlyDyn

38 , switchPromptlyDyn

34 , tagPromptlyDyn

39 , tagPromptlyDyn

35 , attachPromptlyDyn

40 , attachPromptlyDyn

@@ -58,28 +63,8 @@ module Reflex.Dynamic

58 , Demux

63 , Demux

59 , demux

64 , demux

60 , demuxed

65 , demuxed

61− -- Unsafe

66+ -- * Miscellaneous

62− , unsafeDynamic

63− -- * Deprecated functions

64− , apDyn

65− , attachDyn

66− , attachDynWith

67− , attachDynWithMaybe

68− , collectDyn

69− , combineDyn

70− , distributeDMapOverDyn

71− , distributeFHListOverDyn

72− , forDyn

73− , getDemuxed

74− , joinDyn

75− , mapDyn

76− , mconcatDyn

77− , nubDyn

78− , splitDyn

79− , tagDyn

80− , uniqDyn

81− , uniqDynBy

82− -- Things that probably aren't very useful, and are also deprecated

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

83 , HList (..)

68 , HList (..)

84 , FHList (..)

69 , FHList (..)

85 , collectDynPure

70 , collectDynPure

@@ -88,12 +73,13 @@ module Reflex.Dynamic

88 , AllAreFunctors (..)

73 , AllAreFunctors (..)

89 , HListPtr (..)

74 , HListPtr (..)

90 , distributeFHListOverDynPure

75 , distributeFHListOverDynPure

76+ -- * Unsafe

77+ , unsafeDynamic

91 ) where

78 ) where

93import Data.Functor.Misc

80import Data.Functor.Misc

94import Reflex.Class

81import Reflex.Class

96−import Control.Applicative ((<*>))

97import Control.Monad

83import Control.Monad

98import Control.Monad.Fix

84import Control.Monad.Fix

99import Control.Monad.Identity

85import Control.Monad.Identity

@@ -105,7 +91,7 @@ import Data.Functor.Compose (Compose (Compose), getCompose)

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

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

106import Data.Map (Map)

92import Data.Map (Map)

107import Data.Maybe (isJust)

93import Data.Maybe (isJust)

108−import Data.Monoid

94+import Data.Monoid ((<>))

109import Data.These

95import Data.These

110import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), Proxy (Proxy), SListI, SOP (SOP), from, hcmap, hmap, to, unSOP)

96import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), Proxy (Proxy), SListI, SOP (SOP), from, hcmap, hmap, to, unSOP)

111import Generics.SOP.Distribute (distributeI_NP)

97import Generics.SOP.Distribute (distributeI_NP)

@@ -132,7 +118,7 @@ holdUniqDyn = holdUniqDynBy (==)

132holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

118holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

133holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

119holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

134

120

135−-- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing)

121+-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@)

136improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))

122improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))

137improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

123improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

138

124

@@ -176,7 +162,7 @@ foldDynMaybe = accumMaybeDyn . flip

176foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)

162foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)

177foldDynMaybeM = accumMaybeMDyn . flip

163foldDynMaybeM = accumMaybeMDyn . flip

178

164

179−-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.

165+-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'.

180count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

166count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

181count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

167count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

182

168

@@ -185,10 +171,25 @@ count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

185toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

171toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

186toggle = foldDyn (const not)

172toggle = foldDyn (const not)

187

173

174+-- | Switches to the new 'Event' whenever it receives one. Only the old event is

175+-- considered the moment a new one is switched in; the output event will fire at

176+-- that moment if only if the old event does.

177+--

178+-- Prefer this to 'switchPromptlyDyn' where possible. The lack of doing double

179+-- work when the outer and (new) inner fires means this imposes fewer "timing

180+-- requirements" and thus is far more easy to use without introducing fresh

181+-- failure cases. 'switchDyn' is also more performant.

182+switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

183+switchDyn d = switch (current d)

184+

188-- | Switches to the new 'Event' whenever it receives one. Switching occurs

185-- | Switches to the new 'Event' whenever it receives one. Switching occurs

189−-- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the

186+-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the

190-- old and new inner Events fire simultaneously, the output will fire with the

187-- old and new inner Events fire simultaneously, the output will fire with the

191−-- value of the *new* 'Event'.

188+-- value of the __new__ 'Event'.

189+--

190+-- Prefer 'switchDyn' to this where possible. The timing requirements that

191+-- switching before imposes are likely to bring down your app unless you are

192+-- very careful. 'switchDyn' is also more performant.

192switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

193switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

193switchPromptlyDyn de =

194switchPromptlyDyn de =

194 let eLag = switch $ current de

195 let eLag = switch $ current de

@@ -222,10 +223,10 @@ distributeListOverDynPure =

222-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

223-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

223-- with the current values of the 'Dynamic's in a map.

224-- with the current values of the 'Dynamic's in a map.

224joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)

225joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)

225−joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure

226+joinDynThroughMap = join . fmap distributeMapOverDynPure

226

227

227-- | Print the value of the 'Dynamic' when it is first read and on each

228-- | Print the value of the 'Dynamic' when it is first read and on each

228−-- subsequent change that is observed (as traceEvent), prefixed with the

229+-- subsequent change that is observed (as 'traceEvent'), prefixed with the

229-- provided string. This should /only/ be used for debugging.

230-- provided string. This should /only/ be used for debugging.

230--

231--

231-- Note: Just like Debug.Trace.trace, the value will only be shown if something

232-- Note: Just like Debug.Trace.trace, the value will only be shown if something

@@ -235,7 +236,7 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x

235

236

236-- | Print the result of applying the provided function to the value

237-- | Print the result of applying the provided function to the value

237-- of the 'Dynamic' when it is first read and on each subsequent change

238-- of the 'Dynamic' when it is first read and on each subsequent change

238−-- that is observed (as traceEvent). This should /only/ be used for

239+-- that is observed (as 'traceEvent'). This should /only/ be used for

239-- debugging.

240-- debugging.

240--

241--

241-- Note: Just like Debug.Trace.trace, the value will only be shown if something

242-- Note: Just like Debug.Trace.trace, the value will only be shown if something

@@ -251,36 +252,35 @@ traceDynWith f d =

251-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

252-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

252-- each time the 'Event' occurs.

253-- each time the 'Event' occurs.

253--

254--

254−-- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing

255+-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing

255−-- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d`

256+-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@

256−-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value

257+-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value

257-- will be used, since the 'Behavior' won't be updated until the end of the frame.

258-- will be used, since the 'Behavior' won't be updated until the end of the frame.

258-- Additionally, this means that the output 'Event' may not be used to directly change

259-- Additionally, this means that the output 'Event' may not be used to directly change

259−-- the input 'Dynamic', because that would mean its value depends on itself. When creating

260+-- the input 'Dynamic', because that would mean its value depends on itself. __When creating__

260−-- cyclic data flows, generally `tag (current d) e` is preferred.

261+-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__

261tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

262tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

262tagPromptlyDyn = attachPromptlyDynWith const

263tagPromptlyDyn = attachPromptlyDynWith const

263

264

264-- | Attach the current value of the 'Dynamic' to the value of the

265-- | Attach the current value of the 'Dynamic' to the value of the

265-- 'Event' each time it occurs.

266-- 'Event' each time it occurs.

266--

267--

267−-- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details.

268+-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@. See 'tagPromptlyDyn' for details.

268attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

269attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

269attachPromptlyDyn = attachPromptlyDynWith (,)

270attachPromptlyDyn = attachPromptlyDynWith (,)

270

271

271-- | Combine the current value of the 'Dynamic' with the value of the

272-- | Combine the current value of the 'Dynamic' with the value of the

272-- 'Event' each time it occurs.

273-- 'Event' each time it occurs.

273--

274--

274−-- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details.

275+-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@. See 'tagPromptlyDyn' for details.

275attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

276attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

276attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

277attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

277

278

278−-- | Create a new 'Event' by combining the value at each occurence with the

279+-- | Create a new 'Event' by combining the value at each occurrence with the

279-- current value of the 'Dynamic' value and possibly filtering if the combining

280-- current value of the 'Dynamic' value and possibly filtering if the combining

280-- function returns 'Nothing'.

281-- function returns 'Nothing'.

281--

282--

282−-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f

283+-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details.

283−-- (current d)`. See 'tagPromptlyDyn' for details.

284attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

285attachPromptlyDynWithMaybe f d e =

286 let e' = attach (current d) e

@@ -289,8 +289,8 @@ attachPromptlyDynWithMaybe f d e =

289 These (_, b) a -> f a b -- Both events are firing, so use the newer value

290 That _ -> Nothing -- The tagging event isn't firing, so don't fire

291

292−-- | Factor a @Dynamic t (Maybe a)@ into a @Dynamic t (Maybe (Dynamic t a))@,

292+-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@,

293−-- such that the outer 'Dynamic' is updated only when the 'Maybe''s constructor

293+-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor

294-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor

295-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track

296-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the

@@ -312,27 +312,6 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum

312 LeftTag :=> Compose a -> Left $ coerceDynamic a

313 RightTag :=> Compose b -> Right $ coerceDynamic b

314

315−factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

316−factorDyn d = do

317− let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a))

318− inner k v0 = holdDyn v0 . fmapMaybe id =<< takeWhileE isJust newVal

319− where newVal = ffor (updated d) $ \(newK :=> newV) -> case newK `geq` k of

320− Just Refl -> Just newV

321− Nothing -> Nothing

322− getInitial = do

323− k0 :=> (v0 :: v a) <- sample $ current d

324− i0 <- inner k0 v0

325− return $ k0 :=> Compose i0

326− update = flip push (updated d) $ \(newKey :=> newVal) -> do

327− (oldKey :=> _) <- sample $ current d

328− case newKey `geq` oldKey of

329− Just Refl -> return Nothing

330− Nothing -> do

331− newInner <- inner newKey newVal

332− return $ Just $ newKey :=> Compose newInner

333− o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic

334− holdDyn o0 update

335−

336-- | Use factorDyn and generics-sop to turn a Dynamic of a type into a factored

315-- | Use factorDyn and generics-sop to turn a Dynamic of a type into a factored

337-- Dynamic of a type with Dynamic fields. For example:

316-- Dynamic of a type with Dynamic fields. For example:

338--

317--

@@ -341,7 +320,6 @@ factorDyn d = do

341--

320--

342-- > eitherDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))

321-- > eitherDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))

343-- > eitherDyn = factorDynGeneric

322-- > eitherDyn = factorDynGeneric

344−

345factorDynGeneric :: forall t m a b. (Reflex t, MonadFix m, MonadHold t m

323factorDynGeneric :: forall t m a b. (Reflex t, MonadFix m, MonadHold t m

346 , Generic a, Generic b

324 , Generic a, Generic b

347 , (Code b) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code a))

325 , (Code b) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code a))

@@ -356,6 +334,20 @@ factorDynGeneric da = do

356 result = to . SOP <$> nsnpDyn''

334 result = to . SOP <$> nsnpDyn''

357 return result

335 return result

358

336

337+factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)

338+ => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

339+factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where

340+ update :: Event t (DSum k (Compose (Dynamic t) v))

341+ update = flip push (updated d) $ \(newKey :=> newVal) -> do

342+ (oldKey :=> _) <- sample (current d)

343+ case newKey `geq` oldKey of

344+ Just Refl -> return Nothing

345+ Nothing -> Just <$> holdKey (newKey :=> newVal)

346+

347+ holdKey (k :=> v) = do

348+ inner' <- filterEventKey k (updated d)

349+ inner <- holdDyn v inner'

350+ return $ k :=> Compose inner

359--------------------------------------------------------------------------------

351--------------------------------------------------------------------------------

360-- Demux

352-- Demux

361--------------------------------------------------------------------------------

353--------------------------------------------------------------------------------

@@ -369,7 +361,7 @@ factorDynGeneric da = do

369--

361--

370-- > demuxed (demux d) k === fmap (== k) d

362-- > demuxed (demux d) k === fmap (== k) d

371--

363--

372−-- However, the when getDemuxed is used multiple times, the complexity is only

364+-- However, when getDemuxed is used multiple times, the complexity is only

373-- /O(log(n))/, rather than /O(n)/ for fmap.

365-- /O(log(n))/, rather than /O(n)/ for fmap.

374data Demux t k = Demux { demuxValue :: Behavior t k

366data Demux t k = Demux { demuxValue :: Behavior t k

375 , demuxSelector :: EventSelector t (Const2 k Bool)

367 , demuxSelector :: EventSelector t (Const2 k Bool)

@@ -447,21 +439,12 @@ data FHList f l where

447 FHCons :: f e -> FHList f l -> FHList f (e ': l)

439 FHCons :: f e -> FHList f l -> FHList f (e ': l)

448

440

449instance GEq (HListPtr l) where

441instance GEq (HListPtr l) where

450−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

451− geqToEq _ = id

452− geqUnify HHeadPtr HHeadPtr _ same = same

453− geqUnify (HTailPtr a) (HTailPtr b) different same = geqUnify a b different same

454− geqUnify _ _ different _ = different

455−#endif

456 HHeadPtr `geq` HHeadPtr = Just Refl

442 HHeadPtr `geq` HHeadPtr = Just Refl

457 HHeadPtr `geq` HTailPtr _ = Nothing

443 HHeadPtr `geq` HTailPtr _ = Nothing

458 HTailPtr _ `geq` HHeadPtr = Nothing

444 HTailPtr _ `geq` HHeadPtr = Nothing

459 HTailPtr a `geq` HTailPtr b = a `geq` b

445 HTailPtr a `geq` HTailPtr b = a `geq` b

460

446

461instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break

447instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break

462−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

463− gcompareToOrd _ = id

464−#endif

465 HHeadPtr `gcompare` HHeadPtr = GEQ

448 HHeadPtr `gcompare` HHeadPtr = GEQ

466 HHeadPtr `gcompare` HTailPtr _ = GLT

449 HHeadPtr `gcompare` HTailPtr _ = GLT

467 HTailPtr _ `gcompare` HHeadPtr = GGT

450 HTailPtr _ `gcompare` HHeadPtr = GGT

@@ -587,134 +570,3 @@ instance IsHList (a, b, c, d, e, f) where

587#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800

570#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800

588 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139

571 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139

589#endif

572#endif

590−

591−--------------------------------------------------------------------------------

592−-- Deprecated functions

593−--------------------------------------------------------------------------------

594−

595−-- | Map a function over a 'Dynamic'.

596−{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}

597−mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)

598−mapDyn f = return . fmap f

599−

600−-- | Flipped version of 'mapDyn'.

601−{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}

602−forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)

603−forDyn a = return . ffor a

604−

605−-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value

606−-- of the tuple.

607−{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}

608−splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)

609−splitDyn = return . splitDynPure

610−

611−-- | Merge the 'Dynamic' values using their 'Monoid' instance.

612−{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}

613−mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)

614−mconcatDyn = return . mconcat

615−

616−-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.

617−{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}

618−distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))

619−distributeDMapOverDyn = return . distributeDMapOverDynPure

620−

621−-- | Merge two 'Dynamic's into a new one using the provided function. The new

622−-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes

623−-- its value.

624−{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}

625−combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)

626−combineDyn f a b = return $ zipDynWith f a b

627−

628−-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:

629−--

630−-- > do

631−-- > person <- Person `mapDyn` dynFirstName

632−-- > `apDyn` dynListName

633−-- > `apDyn` dynAge

634−-- > `apDyn` dynAddress

635−{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-}

636−#ifdef USE_TEMPLATE_HASKELL

637−{-# ANN apDyn "HLint: ignore Use fmap" #-}

638−#endif

639−apDyn :: forall t m a b. (Reflex t, Monad m)

640− => m (Dynamic t (a -> b))

641− -> Dynamic t a

642− -> m (Dynamic t b)

643−apDyn m a = fmap (<*> a) m

644−

645−--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out

646−-- | This function no longer needs to be monadic, so it has been replaced by

647−-- 'demuxed', which is pure.

648−{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}

649−getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)

650−getDemuxed d = return . demuxed d

651−

652−-- | This function no longer needs to be monadic, so it has been replaced by

653−-- 'distributeFHListOverDynPure', which is pure.

654−{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}

655−distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))

656−distributeFHListOverDyn = return . distributeFHListOverDynPure

657−

658−-- | This function no longer needs to be monadic, so it has been replaced by

659−-- 'collectDynPure', which is pure.

660−{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}

661−collectDyn :: ( RebuildSortedHList (HListElems b)

662− , IsHList a, IsHList b

663− , AllAreFunctors (Dynamic t) (HListElems b)

664− , Reflex t, Monad m

665− , HListElems a ~ FunctorList (Dynamic t) (HListElems b)

666− ) => a -> m (Dynamic t b)

667−collectDyn = return . collectDynPure

668−

669−-- | This function has been renamed to 'tagPromptlyDyn' to clarify its

670−-- semantics.

671−{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}

672−tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

673−tagDyn = tagPromptlyDyn

674−

675−-- | This function has been renamed to 'attachPromptlyDyn' to clarify its

676−-- semantics.

677−{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}

678−attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

679−attachDyn = attachPromptlyDyn

680−

681−-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its

682−-- semantics.

683−{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}

684−attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

685−attachDynWith = attachPromptlyDynWith

686−

687−-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify

688−-- its semantics.

689−{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}

690−attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

691−attachDynWithMaybe = attachPromptlyDynWithMaybe

692−

693−-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s

694−-- current value will always be equal to the current value's current value, and

695−-- will change whenever either the inner or the outer (or both) values change.

696−{-# DEPRECATED joinDyn "Use 'join' instead" #-}

697−joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a

698−joinDyn = join

699−

700−-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests

701−-- representational equality. Use 'holdUniqDyn' instead, which is pure in all

702−-- circumstances. Also, note that, unlike 'nub', this function does not prevent

703−-- all recurrences of a value, only consecutive recurrences.

704−{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

705−nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

706−nubDyn = uniqDyn

707−

708−-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests

709−-- representational equality. Use 'holdUniqDyn' instead, which is pure in all

710−-- circumstances.

711−{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

712−uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

713−uniqDyn = uniqDynBy (==)

714−

715−-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.

716−{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

717−uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a

718−uniqDynBy eq d =

719− let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)

720− in unsafeDynamic (current d) e'

src/Reflex/Dynamic/TH.hs+1−26

@@ -13,9 +13,6 @@ module Reflex.Dynamic.TH

13 ( qDynPure

14 , unqDyn

15 , mkDynPure

16− -- * Deprecated functions

17− , qDyn

18− , mkDyn

19 ) where

16 ) where

21import Generics.SOP (I (..), NP (..))

18import Generics.SOP (I (..), NP (..))

@@ -24,7 +21,7 @@ import Reflex.Dynamic.CollectDynGeneric (collectDynNP)

24import Control.Monad.State

21import Control.Monad.State

25import Data.Data

22import Data.Data

26import Data.Generics

23import Data.Generics

27−import Data.Monoid

24+import Data.Monoid ((<>))

28import qualified Language.Haskell.Exts as Hs

25import qualified Language.Haskell.Exts as Hs

29import qualified Language.Haskell.Meta.Syntax.Translate as Hs

26import qualified Language.Haskell.Meta.Syntax.Translate as Hs

30import Language.Haskell.TH

27import Language.Haskell.TH

@@ -52,7 +49,6 @@ qDynPure qe = do

52 param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs

49 param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs

53 [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |]

50 [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |]

55−

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

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

57-- 'qDyn' quotation.

53-- 'qDyn' quotation.

58unqDyn :: Q Exp -> Q Exp

54unqDyn :: Q Exp -> Q Exp

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

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

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

110 | modName == modName' && occName == occName' = 'unqMarker

106 | modName == modName' && occName == occName' = 'unqMarker

111 reinstateUnqDyn x = x

107 reinstateUnqDyn x = x

112−

113−--------------------------------------------------------------------------------

114−-- Deprecated

115−--------------------------------------------------------------------------------

116−

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

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

119−-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

120−qDyn :: Q Exp -> Q Exp

121−qDyn qe = [| return $(qDynPure qe) |]

122−

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

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

125−-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

126−mkDyn :: QuasiQuoter

127−mkDyn = QuasiQuoter

128− { quoteExp = \s -> [| return $(mkDynExp s) |]

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

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

131− , quoteDec = error "mkDyn: declaration splices are not supported"

132− }

src/Reflex/DynamicWriter.hs+4−221

@@ -1,224 +1,7 @@

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

2−-- implementation.

3−{-# LANGUAGE CPP #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−#ifdef USE_REFLEX_OPTIMIZER

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

16−#endif

17module Reflex.DynamicWriter

1module Reflex.DynamicWriter

18− ( MonadDynamicWriter (..)

2+ {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-}

19− , DynamicWriterT (..)

3+ ( module X

20− , runDynamicWriterT

21− , withDynamicWriterT

22 ) where

4 ) where

24−import Control.Monad.Exception

6+import Reflex.DynamicWriter.Base as X

25−import Control.Monad.Identity

26−import Control.Monad.IO.Class

27−import Control.Monad.Reader

28−import Control.Monad.Ref

29−import Control.Monad.State.Strict

30−import Data.Align

31−import Data.Dependent.Map (DMap)

32−import qualified Data.Dependent.Map as DMap

33−import Data.FastMutableIntMap

34−import Data.Functor.Misc

35−import Data.IntMap (IntMap)

36−import qualified Data.IntMap as IntMap

37−import Data.Map (Map)

38−import qualified Data.Map as Map

39−import Data.Semigroup

40−import Data.Some (Some)

41−import Data.These

42−import Reflex.Class

7+import Reflex.DynamicWriter.Class as X

43−import Reflex.Host.Class

44−import qualified Reflex.Patch.MapWithMove as MapWithMove

45−import Reflex.PerformEvent.Class

46−import Reflex.PostBuild.Class

47−import Reflex.Requester.Class

48−import Reflex.TriggerEvent.Class

49−

50−instance MonadTrans (DynamicWriterT t w) where

51− lift = DynamicWriterT . lift

52−

53−mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')

54−mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

55−

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

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

58− where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a

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

60−

61−mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)

62−mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

63− where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a

64− addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m

65−

66−mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)

67−mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues

68− where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a

69− addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove

70− f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v

71− f x = unsafePatchMapWithMove $

72− let (p, changed) = case x of

73− This p_ -> (unPatchMapWithMove p_, mempty)

74− That c -> (mempty, c)

75− These p_ c -> (unPatchMapWithMove p_, c)

76− (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case

77− MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v

78− MapWithMove.From_Delete -> return $ MapWithMove.From_Delete

79− MapWithMove.From_Move k -> case Map.lookup k changed of

80− Nothing -> return $ MapWithMove.From_Move k

81− Just v -> do

82− modify (k:)

83− return $ MapWithMove.From_Insert v

84− noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved

85− in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?

86−

87−-- | A basic implementation of 'MonadDynamicWriter'.

88−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

89−

90−instance MonadRef m => MonadRef (DynamicWriterT t w m) where

91− type Ref (DynamicWriterT t w m) = Ref m

92− newRef = lift . newRef

93− readRef = lift . readRef

94− writeRef r = lift . writeRef r

95−

96−instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where

97− atomicModifyRef r = lift . atomicModifyRef r

98−

99−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where

100− newEventWithTrigger = lift . newEventWithTrigger

101− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

102−

103−-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided

104−-- along with the result of the action.

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

106−runDynamicWriterT (DynamicWriterT a) = do

107− (result, ws) <- runStateT a []

108− return (result, mconcat $ reverse ws)

109−

110−-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'

111−-- and combines them monoidally to provide a 'Dynamic' result.

112−class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where

113− tellDyn :: Dynamic t w -> m ()

114−

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

116− tellDyn w = DynamicWriterT $ modify (w :)

117−

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

119− ask = lift ask

120− local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

121− reader = lift . reader

122−

123−instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

124− type Performable (DynamicWriterT t w m) = Performable m

125− performEvent_ = lift . performEvent_

126− performEvent = lift . performEvent

127−

128−instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where

129− newTriggerEvent = lift newTriggerEvent

130− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

131− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

132−

133−instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where

134− getPostBuild = lift getPostBuild

135−

136−instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where

137− tellDyn = lift . tellDyn

138−

139−instance MonadState s m => MonadState s (DynamicWriterT t w m) where

140− get = lift get

141− put = lift . put

142−

143−newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)

144−

145−-- | When the execution of a 'DynamicWriterT' action is adjusted using

146−-- 'Adjustable', the 'Dynamic' output of that action will also be updated to

147−-- match.

148−instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where

149− runWithReplace a0 a' = do

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

151− tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

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

153− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental

154− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

155− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove

156−

157−traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)

158− => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))

159− -> DMap k v

160− -> Event t (p k v)

161− -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))

162− )

163− -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')

164− -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))

165− -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))

166− -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))

167− -> DMap k v

168− -> Event t (p k v)

169− -> DynamicWriterT t w m (DMap k v', Event t (p k v'))

170−traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do

171− (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'

172− let getValue (DynamicWriterTLoweredResult (v, _)) = v

173− getWritten (DynamicWriterTLoweredResult (_, w)) = w

174− liftedResult0 = DMap.map getValue result0

175− liftedResult' = ffor result' $ mapPatch getValue

176− liftedWritten0 :: Map (Some k) (Dynamic t w)

177− liftedWritten0 = weakenDMapWith getWritten result0

178− liftedWritten' = ffor result' $ weakenPatchWith getWritten

179− --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

180− i <- holdIncremental liftedWritten0 liftedWritten'

181− tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

182− return (liftedResult0, liftedResult')

183−

184−traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')

185− => ( (IntMap.Key -> v -> m ((v', Dynamic t w)))

186− -> IntMap v

187− -> Event t (p v)

188− -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))

189− )

190− -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))

191− -> (IntMap.Key -> v -> DynamicWriterT t w m v')

192− -> IntMap v

193− -> Event t (p v)

194− -> DynamicWriterT t w m (IntMap v', Event t (p v'))

195−traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do

196− (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'

197− let liftedResult0 = fmap fst result0

198− liftedResult' = fmap (fmap fst) result'

199− liftedWritten0 :: IntMap (Dynamic t w)

200− liftedWritten0 = fmap snd result0

201− liftedWritten' = fmap (fmap snd) result'

202− --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

203− i <- holdIncremental liftedWritten0 liftedWritten'

204− tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

205− return (liftedResult0, liftedResult')

206−

207−-- | Map a function over the output of a 'DynamicWriterT'.

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

209− => (w -> w')

210− -> DynamicWriterT t w m a

211− -> DynamicWriterT t w' m a

212−withDynamicWriterT f dw = do

213− (r, d) <- lift $ do

214− (r, d) <- runDynamicWriterT dw

215− let d' = fmap f d

216− return (r, d')

217− tellDyn d

218− return r

219−

220−instance Requester t m => Requester t (DynamicWriterT t w m) where

221− type Request (DynamicWriterT t w m) = Request m

222− type Response (DynamicWriterT t w m) = Response m

223− requesting = lift . requesting

224− requesting_ = lift . requesting_

src/Reflex/DynamicWriter/Base.hsnew file+237

@@ -0,0 +1,237 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TupleSections #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+#ifdef USE_REFLEX_OPTIMIZER

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

15+#endif

16+module Reflex.DynamicWriter.Base

17+ ( DynamicWriterT (..)

18+ , runDynamicWriterT

19+ , withDynamicWriterT

20+ ) where

21+

22+import Control.Monad.Exception

23+import Control.Monad.Identity

24+import Control.Monad.IO.Class

25+import Control.Monad.Primitive

26+import Control.Monad.Reader

27+import Control.Monad.Ref

28+import Control.Monad.State.Strict

29+import Data.Align

30+import Data.Dependent.Map (DMap)

31+import qualified Data.Dependent.Map as DMap

32+import Data.FastMutableIntMap

33+import Data.Functor.Misc

34+import Data.IntMap (IntMap)

35+import qualified Data.IntMap as IntMap

36+import Data.Map (Map)

37+import qualified Data.Map as Map

38+import Data.Semigroup (Semigroup(..))

39+import Data.Some (Some)

40+import Data.These

41+

42+import Reflex.Adjustable.Class

43+import Reflex.Class

44+import Reflex.DynamicWriter.Class

45+import Reflex.EventWriter.Class (EventWriter, tellEvent)

46+import Reflex.Host.Class

47+import qualified Reflex.Patch.MapWithMove as MapWithMove

48+import Reflex.PerformEvent.Class

49+import Reflex.PostBuild.Class

50+import Reflex.Query.Class

51+import Reflex.Requester.Class

52+import Reflex.TriggerEvent.Class

53+

54+instance MonadTrans (DynamicWriterT t w) where

55+ lift = DynamicWriterT . lift

56+

57+mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')

58+mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

59+

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

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

62+ where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a

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

64+

65+mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)

66+mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

67+ where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a

68+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m

69+

70+mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)

71+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues

72+ where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a

73+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove

74+ f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v

75+ f x = unsafePatchMapWithMove $

76+ let (p, changed) = case x of

77+ This p_ -> (unPatchMapWithMove p_, mempty)

78+ That c -> (mempty, c)

79+ These p_ c -> (unPatchMapWithMove p_, c)

80+ (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case

81+ MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v

82+ MapWithMove.From_Delete -> return MapWithMove.From_Delete

83+ MapWithMove.From_Move k -> case Map.lookup k changed of

84+ Nothing -> return $ MapWithMove.From_Move k

85+ Just v -> do

86+ modify (k:)

87+ return $ MapWithMove.From_Insert v

88+ noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved

89+ in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?

90+

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

92+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }

93+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order

94+

95+deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)

96+deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)

97+

98+

99+instance MonadRef m => MonadRef (DynamicWriterT t w m) where

100+ type Ref (DynamicWriterT t w m) = Ref m

101+ newRef = lift . newRef

102+ readRef = lift . readRef

103+ writeRef r = lift . writeRef r

104+

105+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where

106+ atomicModifyRef r = lift . atomicModifyRef r

107+

108+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where

109+ newEventWithTrigger = lift . newEventWithTrigger

110+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

111+

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

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

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

115+runDynamicWriterT (DynamicWriterT a) = do

116+ (result, ws) <- runStateT a []

117+ return (result, mconcat $ reverse ws)

118+

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

120+ tellDyn w = DynamicWriterT $ modify (w :)

121+

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

123+ ask = lift ask

124+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

125+ reader = lift . reader

126+

127+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

128+ type Performable (DynamicWriterT t w m) = Performable m

129+ performEvent_ = lift . performEvent_

130+ performEvent = lift . performEvent

131+

132+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where

133+ newTriggerEvent = lift newTriggerEvent

134+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

135+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

136+

137+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where

138+ getPostBuild = lift getPostBuild

139+

140+instance MonadState s m => MonadState s (DynamicWriterT t w m) where

141+ get = lift get

142+ put = lift . put

143+

144+instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where

145+ type PrimState (DynamicWriterT t w m) = PrimState m

146+ primitive = lift . primitive

147+

148+newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)

149+

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

151+-- 'Adjustable', the 'Dynamic' output of that action will also be updated to

152+-- match.

153+instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where

154+ runWithReplace a0 a' = do

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

156+ tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

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

158+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental

159+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

160+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove

161+

162+traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)

163+ => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))

164+ -> DMap k v

165+ -> Event t (p k v)

166+ -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))

167+ )

168+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')

169+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))

170+ -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))

171+ -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))

172+ -> DMap k v

173+ -> Event t (p k v)

174+ -> DynamicWriterT t w m (DMap k v', Event t (p k v'))

175+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do

176+ (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'

177+ let getValue (DynamicWriterTLoweredResult (v, _)) = v

178+ getWritten (DynamicWriterTLoweredResult (_, w)) = w

179+ liftedResult0 = DMap.map getValue result0

180+ liftedResult' = ffor result' $ mapPatch getValue

181+ liftedWritten0 :: Map (Some k) (Dynamic t w)

182+ liftedWritten0 = weakenDMapWith getWritten result0

183+ liftedWritten' = ffor result' $ weakenPatchWith getWritten

184+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

185+ i <- holdIncremental liftedWritten0 liftedWritten'

186+ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

187+ return (liftedResult0, liftedResult')

188+

189+traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')

190+ => ( (IntMap.Key -> v -> m (v', Dynamic t w))

191+ -> IntMap v

192+ -> Event t (p v)

193+ -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))

194+ )

195+ -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))

196+ -> (IntMap.Key -> v -> DynamicWriterT t w m v')

197+ -> IntMap v

198+ -> Event t (p v)

199+ -> DynamicWriterT t w m (IntMap v', Event t (p v'))

200+traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do

201+ (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'

202+ let liftedResult0 = fmap fst result0

203+ liftedResult' = fmap (fmap fst) result'

204+ liftedWritten0 :: IntMap (Dynamic t w)

205+ liftedWritten0 = fmap snd result0

206+ liftedWritten' = fmap (fmap snd) result'

207+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

208+ i <- holdIncremental liftedWritten0 liftedWritten'

209+ tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

210+ return (liftedResult0, liftedResult')

211+

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

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

214+ => (w -> w')

215+ -> DynamicWriterT t w m a

216+ -> DynamicWriterT t w' m a

217+withDynamicWriterT f dw = do

218+ (r, d) <- lift $ do

219+ (r, d) <- runDynamicWriterT dw

220+ let d' = fmap f d

221+ return (r, d')

222+ tellDyn d

223+ return r

224+

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

226+ type Request (DynamicWriterT t w m) = Request m

227+ type Response (DynamicWriterT t w m) = Response m

228+ requesting = lift . requesting

229+ requesting_ = lift . requesting_

230+

231+instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where

232+ tellQueryIncremental = lift . tellQueryIncremental

233+ askQueryResult = lift askQueryResult

234+ queryIncremental = lift . queryIncremental

235+

236+instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where

237+ tellEvent = lift . tellEvent

src/Reflex/DynamicWriter/Class.hsnew file+24

@@ -0,0 +1,24 @@

1+-- | This module defines the 'MonadDynamicWriter' class.

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE UndecidableInstances #-}

7+#ifdef USE_REFLEX_OPTIMIZER

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

9+#endif

10+module Reflex.DynamicWriter.Class

11+ ( MonadDynamicWriter (..)

12+ ) where

13+

14+import Control.Monad.Reader (ReaderT, lift)

15+import Reflex.Class (Dynamic)

16+

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

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

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

20+ tellDyn :: Dynamic t w -> m ()

21+

22+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where

23+ tellDyn = lift . tellDyn

24+

src/Reflex/EventWriter.hs+4−279

@@ -1,282 +1,7 @@

1−-- | This module provides 'EventWriterT', the standard implementation of

2−-- 'EventWriter'.

3−{-# LANGUAGE CPP #-}

4−{-# LANGUAGE ExistentialQuantification #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE Rank2Types #-}

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

17module Reflex.EventWriter

1module Reflex.EventWriter

18− ( EventWriterT (..)

2+ {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}

19− , runEventWriterT

3+ ( module X

20− , EventWriter (..)

21− , runWithReplaceEventWriterTWith

22− , sequenceDMapWithAdjustEventWriterTWith

23− , withEventWriterT

24 ) where

4 ) where

26−import Reflex.Class

6+import Reflex.EventWriter.Base as X

27−import Reflex.Host.Class

28−import Reflex.PerformEvent.Class

29−import Reflex.PostBuild.Class

30−import Reflex.Query.Class

7+import Reflex.EventWriter.Class as X

31−import Reflex.Requester.Class

32−import Reflex.TriggerEvent.Class

33−

34−import Control.Monad.Exception

35−import Control.Monad.Identity

36−import Control.Monad.Reader

37−import Control.Monad.Ref

38−import Control.Monad.State.Strict

39−import Data.Dependent.Map (DMap, DSum (..))

40−import qualified Data.Dependent.Map as DMap

41−import Data.Foldable

42−import Data.Functor.Compose

43−import Data.Functor.Misc

44−import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))

45−import Data.IntMap.Strict (IntMap)

46−import qualified Data.IntMap.Strict as IntMap

47−import Data.List.NonEmpty (NonEmpty (..))

48−import Data.Map (Map)

49−import Data.Semigroup

50−import Data.Some (Some)

51−import Data.Tuple

52−import Data.Type.Equality

53−

54−import Unsafe.Coerce

55−

56−-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'

57−-- and combines them monoidally to provide an 'Event' result.

58−class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where

59− tellEvent :: Event t w -> m ()

60−

61−{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

62−newtype TellId w x

63− = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead

64− deriving (Show, Eq, Ord, Enum)

65−

66−tellId :: Int -> TellId w w

67−tellId = TellId

68−{-# INLINE tellId #-}

69−

70−tellIdRefl :: TellId w x -> w :~: x

71−tellIdRefl _ = unsafeCoerce Refl

72−

73−withTellIdRefl :: TellId w x -> (w ~ x => r) -> r

74−withTellIdRefl tid r = case tellIdRefl tid of

75− Refl -> r

76−

77−instance GEq (TellId w) where

78− a `geq` b =

79− withTellIdRefl a $

80− withTellIdRefl b $

81− if a == b

82− then Just Refl

83− else Nothing

84−

85−instance GCompare (TellId w) where

86− a `gcompare` b =

87− withTellIdRefl a $

88− withTellIdRefl b $

89− case a `compare` b of

90− LT -> GLT

91− EQ -> GEQ

92− GT -> GGT

93−

94−data EventWriterState t w = EventWriterState

95− { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)

96− , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order

97− }

98−

99−-- | A basic implementation of 'EventWriter'.

100−newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

101− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

102−

103−-- | Run a 'EventWriterT' action.

104−runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

105−runEventWriterT (EventWriterT a) = do

106− (result, requests) <- runStateT a $ EventWriterState (-1) []

107− let combineResults :: DMap (TellId w) Identity -> w

108− combineResults = sconcat

109− . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

110− . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order

111− return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

112−

113−instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

114− tellEvent w = EventWriterT $ modify $ \old ->

115− let myId = _eventWriterState_nextId old

116− in EventWriterState

117− { _eventWriterState_nextId = pred myId

118− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

119− }

120−

121−instance EventWriter t w m => EventWriter t w (ReaderT r m) where

122− tellEvent = lift . tellEvent

123−

124−instance MonadTrans (EventWriterT t w) where

125− lift = EventWriterT . lift

126−

127−instance MonadSample t m => MonadSample t (EventWriterT t w m) where

128− sample = lift . sample

129−

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

131− {-# INLINABLE hold #-}

132− hold v0 = lift . hold v0

133− {-# INLINABLE holdDyn #-}

134− holdDyn v0 = lift . holdDyn v0

135− {-# INLINABLE holdIncremental #-}

136− holdIncremental v0 = lift . holdIncremental v0

137− {-# INLINABLE buildDynamic #-}

138− buildDynamic a0 = lift . buildDynamic a0

139− {-# INLINABLE headE #-}

140− headE = lift . headE

141−

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

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

144− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental

145− traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental

146− traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove

147−

148−instance Requester t m => Requester t (EventWriterT t w m) where

149− type Request (EventWriterT t w m) = Request m

150− type Response (EventWriterT t w m) = Response m

151− requesting = lift . requesting

152− requesting_ = lift . requesting_

153−

154−-- | Given a function like 'runWithReplace' for the underlying monad, implement

155−-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

156−-- monad doesn't have a 'Adjustable' instance or to override the default

157−-- 'Adjustable' behavior.

158−runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)

159− => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

160− -> EventWriterT t w m a

161− -> Event t (EventWriterT t w m b)

162− -> EventWriterT t w m (a, Event t b)

163−runWithReplaceEventWriterTWith f a0 a' = do

164− (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'

165− request <- holdDyn (snd result0) $ fmapCheap snd result'

166− -- 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.)

167− tellEvent $ coincidence $ updated request

168− tellEvent $ switch $ current request

169− return (fst result0, fmapCheap fst result')

170−

171−-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

172−sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))

173− => ( (IntMap.Key -> v -> m (Event t w, v'))

174− -> IntMap v

175− -> Event t (p v)

176− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

177− )

178− -> (p (Event t w) -> [Event t w])

179− -> (Incremental t (p (Event t w)) -> Event t (IntMap w))

180− -> (IntMap.Key -> v -> EventWriterT t w m v')

181− -> IntMap v

182− -> Event t (p v)

183− -> EventWriterT t w m (IntMap v', Event t (p v'))

184−sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

185− let f' :: IntMap.Key -> v -> m (Event t w, v')

186− f' k v = swap <$> runEventWriterT (f k v)

187− (children0, children') <- base f' dm0 dm'

188− let result0 = fmap snd children0

189− result' = fmapCheap (fmap snd) children'

190− requests0 :: IntMap (Event t w)

191− requests0 = fmap fst children0

192− requests' :: Event t (p (Event t w))

193− requests' = fmapCheap (fmap fst) children'

194− childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'

195− -- 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.)

196− tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

197− tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

198− [] -> Nothing

199− h : t -> Just $ sconcat $ h :| t

200− return (result0, result')

201−

202−-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

203−sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))

204− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

205− -> DMap k v

206− -> Event t (p k v)

207− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

208− )

209− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

210− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

211− -> (p' (Some k) (Event t w) -> [Event t w])

212− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))

213− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

214− -> DMap k v

215− -> Event t (p k v)

216− -> EventWriterT t w m (DMap k v', Event t (p k v'))

217−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

218− let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)

219− f' k v = Compose . swap <$> runEventWriterT (f k v)

220− (children0, children') <- base f' dm0 dm'

221− let result0 = DMap.map (snd . getCompose) children0

222− result' = fforCheap children' $ mapPatch $ snd . getCompose

223− requests0 :: Map (Some k) (Event t w)

224− requests0 = weakenDMapWith (fst . getCompose) children0

225− requests' :: Event t (p' (Some k) (Event t w))

226− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

227− childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'

228− -- 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.)

229− tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

230− tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

231− [] -> Nothing

232− h : t -> Just $ sconcat $ h :| t

233− return (result0, result')

234−

235−instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

236− type Performable (EventWriterT t w m) = Performable m

237− performEvent_ = lift . performEvent_

238− performEvent = lift . performEvent

239−

240−instance PostBuild t m => PostBuild t (EventWriterT t w m) where

241− getPostBuild = lift getPostBuild

242−

243−instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where

244− newTriggerEvent = lift newTriggerEvent

245− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

246− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

247−

248−instance MonadReader r m => MonadReader r (EventWriterT t w m) where

249− ask = lift ask

250− local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a

251− reader = lift . reader

252−

253−instance MonadRef m => MonadRef (EventWriterT t w m) where

254− type Ref (EventWriterT t w m) = Ref m

255− newRef = lift . newRef

256− readRef = lift . readRef

257− writeRef r = lift . writeRef r

258−

259−instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

260− atomicModifyRef r = lift . atomicModifyRef r

261−

262−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

263− newEventWithTrigger = lift . newEventWithTrigger

264− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

265−

266−instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where

267− tellQueryIncremental = lift . tellQueryIncremental

268− askQueryResult = lift askQueryResult

269− queryIncremental = lift . queryIncremental

270−

271−-- | Map a function over the output of a 'EventWriterT'.

272−withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)

273− => (w -> w')

274− -> EventWriterT t w m a

275− -> EventWriterT t w' m a

276−withEventWriterT f ew = do

277− (r, e) <- lift $ do

278− (r, e) <- runEventWriterT ew

279− let e' = fmap f e

280− return (r, e')

281− tellEvent e

282− return r

src/Reflex/EventWriter/Base.hsnew file+306

@@ -0,0 +1,306 @@

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

2+-- 'EventWriter'.

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE Rank2Types #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+#ifdef USE_REFLEX_OPTIMIZER

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

15+#endif

16+module Reflex.EventWriter.Base

17+ ( EventWriterT (..)

18+ , runEventWriterT

19+ , runWithReplaceEventWriterTWith

20+ , sequenceDMapWithAdjustEventWriterTWith

21+ , mapEventWriterT

22+ , withEventWriterT

23+ ) where

24+

25+import Reflex.Adjustable.Class

26+import Reflex.Class

27+import Reflex.EventWriter.Class (EventWriter, tellEvent)

28+import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn)

29+import Reflex.Host.Class

30+import Reflex.PerformEvent.Class

31+import Reflex.PostBuild.Class

32+import Reflex.Query.Class

33+import Reflex.Requester.Class

34+import Reflex.TriggerEvent.Class

35+

36+import Control.Monad.Exception

37+import Control.Monad.Identity

38+import Control.Monad.Primitive

39+import Control.Monad.Reader

40+import Control.Monad.Ref

41+import Control.Monad.State.Strict

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

43+import qualified Data.Dependent.Map as DMap

44+import Data.Functor.Compose

45+import Data.Functor.Misc

46+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

47+import Data.IntMap.Strict (IntMap)

48+import qualified Data.IntMap.Strict as IntMap

49+import Data.List.NonEmpty (NonEmpty (..))

50+import Data.Map (Map)

51+import qualified Data.Map as Map

52+import Data.Semigroup

53+import Data.Some (Some)

54+import Data.Tuple

55+import Data.Type.Equality hiding (apply)

56+

57+import Unsafe.Coerce

58+

59+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

60+newtype TellId w x

61+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead

62+ deriving (Show, Eq, Ord, Enum)

63+

64+tellId :: Int -> TellId w w

65+tellId = TellId

66+{-# INLINE tellId #-}

67+

68+tellIdRefl :: TellId w x -> w :~: x

69+tellIdRefl _ = unsafeCoerce Refl

70+

71+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r

72+withTellIdRefl tid r = case tellIdRefl tid of

73+ Refl -> r

74+

75+instance GEq (TellId w) where

76+ a `geq` b =

77+ withTellIdRefl a $

78+ withTellIdRefl b $

79+ if a == b

80+ then Just Refl

81+ else Nothing

82+

83+instance GCompare (TellId w) where

84+ a `gcompare` b =

85+ withTellIdRefl a $

86+ withTellIdRefl b $

87+ case a `compare` b of

88+ LT -> GLT

89+ EQ -> GEQ

90+ GT -> GGT

91+

92+data EventWriterState t w = EventWriterState

93+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)

94+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order

95+ }

96+

97+-- | A basic implementation of 'EventWriter'.

98+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

99+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

100+

101+-- | Run a 'EventWriterT' action.

102+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

103+runEventWriterT (EventWriterT a) = do

104+ (result, requests) <- runStateT a $ EventWriterState (-1) []

105+ let combineResults :: DMap (TellId w) Identity -> w

106+ combineResults = sconcat

107+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

108+ . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order

109+ return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

110+

111+instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

112+ tellEvent w = EventWriterT $ modify $ \old ->

113+ let myId = _eventWriterState_nextId old

114+ in EventWriterState

115+ { _eventWriterState_nextId = pred myId

116+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

117+ }

118+

119+instance MonadTrans (EventWriterT t w) where

120+ lift = EventWriterT . lift

121+

122+instance MonadSample t m => MonadSample t (EventWriterT t w m) where

123+ sample = lift . sample

124+

125+instance MonadHold t m => MonadHold t (EventWriterT t w m) where

126+ {-# INLINABLE hold #-}

127+ hold v0 = lift . hold v0

128+ {-# INLINABLE holdDyn #-}

129+ holdDyn v0 = lift . holdDyn v0

130+ {-# INLINABLE holdIncremental #-}

131+ holdIncremental v0 = lift . holdIncremental v0

132+ {-# INLINABLE buildDynamic #-}

133+ buildDynamic a0 = lift . buildDynamic a0

134+ {-# INLINABLE headE #-}

135+ headE = lift . headE

136+

137+instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where

138+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

139+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap

140+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap

141+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove

142+

143+instance Requester t m => Requester t (EventWriterT t w m) where

144+ type Request (EventWriterT t w m) = Request m

145+ type Response (EventWriterT t w m) = Response m

146+ requesting = lift . requesting

147+ requesting_ = lift . requesting_

148+

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

150+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

151+-- monad doesn't have a 'Adjustable' instance or to override the default

152+-- 'Adjustable' behavior.

153+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)

154+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

155+ -> EventWriterT t w m a

156+ -> Event t (EventWriterT t w m b)

157+ -> EventWriterT t w m (a, Event t b)

158+runWithReplaceEventWriterTWith f a0 a' = do

159+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'

160+ tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')

161+ return (fst result0, fmapCheap fst result')

162+

163+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

164+sequenceIntMapWithAdjustEventWriterTWith

165+ :: forall t m p w v v'

166+ . ( Reflex t

167+ , MonadHold t m

168+ , Semigroup w

169+ , Functor p

170+ , Patch (p (Event t w))

171+ , PatchTarget (p (Event t w)) ~ IntMap (Event t w)

172+ , Patch (p w)

173+ , PatchTarget (p w) ~ IntMap w

174+ )

175+ => ( (IntMap.Key -> v -> m (Event t w, v'))

176+ -> IntMap v

177+ -> Event t (p v)

178+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

179+ )

180+ -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))

181+ -> (Event t (p (Event t w)) -> Event t (p w))

182+ -> (IntMap.Key -> v -> EventWriterT t w m v')

183+ -> IntMap v

184+ -> Event t (p v)

185+ -> EventWriterT t w m (IntMap v', Event t (p v'))

186+sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do

187+ let f' :: IntMap.Key -> v -> m (Event t w, v')

188+ f' k v = swap <$> runEventWriterT (f k v)

189+ (children0, children') <- base f' dm0 dm'

190+ let result0 = fmap snd children0

191+ result' = fmapCheap (fmap snd) children'

192+ requests0 :: IntMap (Event t w)

193+ requests0 = fmap fst children0

194+ requests' :: Event t (p (Event t w))

195+ requests' = fmapCheap (fmap fst) children'

196+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

197+ tellEvent $ fforMaybeCheap e $ \m ->

198+ case IntMap.elems m of

199+ [] -> Nothing

200+ h : t -> Just $ sconcat $ h :| t

201+ return (result0, result')

202+

203+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

204+sequenceDMapWithAdjustEventWriterTWith

205+ :: forall t m p p' w k v v'

206+ . ( Reflex t

207+ , MonadHold t m

208+ , Semigroup w

209+ , Patch (p' (Some k) (Event t w))

210+ , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)

211+ , GCompare k

212+ , Patch (p' (Some k) w)

213+ , PatchTarget (p' (Some k) w) ~ Map (Some k) w

214+ )

215+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

216+ -> DMap k v

217+ -> Event t (p k v)

218+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

219+ )

220+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

221+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

222+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))

223+ -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))

224+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

225+ -> DMap k v

226+ -> Event t (p k v)

227+ -> EventWriterT t w m (DMap k v', Event t (p k v'))

228+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do

229+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)

230+ f' k v = Compose . swap <$> runEventWriterT (f k v)

231+ (children0, children') <- base f' dm0 dm'

232+ let result0 = DMap.map (snd . getCompose) children0

233+ result' = fforCheap children' $ mapPatch $ snd . getCompose

234+ requests0 :: Map (Some k) (Event t w)

235+ requests0 = weakenDMapWith (fst . getCompose) children0

236+ requests' :: Event t (p' (Some k) (Event t w))

237+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

238+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

239+ tellEvent $ fforMaybeCheap e $ \m ->

240+ case Map.elems m of

241+ [] -> Nothing

242+ h : t -> Just $ sconcat $ h :| t

243+ return (result0, result')

244+

245+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

246+ type Performable (EventWriterT t w m) = Performable m

247+ performEvent_ = lift . performEvent_

248+ performEvent = lift . performEvent

249+

250+instance PostBuild t m => PostBuild t (EventWriterT t w m) where

251+ getPostBuild = lift getPostBuild

252+

253+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where

254+ newTriggerEvent = lift newTriggerEvent

255+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

256+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

257+

258+instance MonadReader r m => MonadReader r (EventWriterT t w m) where

259+ ask = lift ask

260+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a

261+ reader = lift . reader

262+

263+instance MonadRef m => MonadRef (EventWriterT t w m) where

264+ type Ref (EventWriterT t w m) = Ref m

265+ newRef = lift . newRef

266+ readRef = lift . readRef

267+ writeRef r = lift . writeRef r

268+

269+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

270+ atomicModifyRef r = lift . atomicModifyRef r

271+

272+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

273+ newEventWithTrigger = lift . newEventWithTrigger

274+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

275+

276+instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where

277+ tellQueryIncremental = lift . tellQueryIncremental

278+ askQueryResult = lift askQueryResult

279+ queryIncremental = lift . queryIncremental

280+

281+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where

282+ tellDyn = lift . tellDyn

283+

284+instance PrimMonad m => PrimMonad (EventWriterT t w m) where

285+ type PrimState (EventWriterT t w m) = PrimState m

286+ primitive = lift . primitive

287+

288+-- | Map a function over the output of a 'EventWriterT'.

289+withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)

290+ => (w -> w')

291+ -> EventWriterT t w m a

292+ -> EventWriterT t w' m a

293+withEventWriterT f ew = do

294+ (r, e) <- lift $ do

295+ (r, e) <- runEventWriterT ew

296+ let e' = fmap f e

297+ return (r, e')

298+ tellEvent e

299+ return r

300+

301+-- | Change the monad underlying an EventWriterT

302+mapEventWriterT

303+ :: (forall x. m x -> n x)

304+ -> EventWriterT t w m a

305+ -> EventWriterT t w n a

306+mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a

src/Reflex/EventWriter/Class.hsnew file+27

@@ -0,0 +1,27 @@

1+-- | This module defines the 'EventWriter' class.

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE UndecidableInstances #-}

7+#ifdef USE_REFLEX_OPTIMIZER

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

9+#endif

10+module Reflex.EventWriter.Class

11+ ( EventWriter (..)

12+ ) where

13+

14+import Control.Monad.Reader (ReaderT, lift)

15+import Data.Semigroup (Semigroup)

16+

17+import Reflex.Class (Event)

18+

19+

20+-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'

21+-- and combines them via 'Semigroup' to provide an 'Event' result.

22+class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where

23+ tellEvent :: Event t w -> m ()

24+

25+

26+instance EventWriter t w m => EventWriter t w (ReaderT r m) where

27+ tellEvent = lift . tellEvent

src/Reflex/FastWeak.hs+63−6

@@ -5,6 +5,19 @@

5{-# LANGUAGE ForeignFunctionInterface #-}

6{-# LANGUAGE JavaScriptFFI #-}

7#endif

9+-- |

10+-- Module:

11+-- Reflex.FastWeak

12+-- Description:

13+-- 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value

14+-- referred to by a 'FastWeak' stays live while the ticket is held (live).

15+--

16+-- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper

17+-- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same.

18+--

19+-- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly

20+-- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS.

8module Reflex.FastWeak

21module Reflex.FastWeak

9 ( FastWeakTicket

22 ( FastWeakTicket

10 , FastWeak

23 , FastWeak

@@ -35,29 +48,57 @@ import System.Mem.Weak

37#ifdef GHCJS_FAST_WEAK

50#ifdef GHCJS_FAST_WEAK

51+-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'

52+-- can be used to get the referred to value without fear of @Nothing,

53+-- and 'getFastWeakTicketWeak' can be used to get the weak version.

54+--

55+-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@.

38newtype FastWeakTicket a = FastWeakTicket JSVal

56newtype FastWeakTicket a = FastWeakTicket JSVal

58+-- | A reference to some value which can be garbage collected if there are only

59+-- weak references to the value left.

60+--

61+-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.

62+--

63+-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using

64+-- 'getFastWeakTicket' if the value hasn't been collected yet.

65+--

66+-- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@.

40newtype FastWeak a = FastWeak JSVal

67newtype FastWeak a = FastWeak JSVal

42-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

69-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

43data Val a = Val { unVal :: a }

70data Val a = Val { unVal :: a }

45−-- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a'

72+-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@

46unsafeFromRawJSVal :: JSVal -> a

73unsafeFromRawJSVal :: JSVal -> a

47unsafeFromRawJSVal v = unVal (unsafeCoerce v)

74unsafeFromRawJSVal v = unVal (unsafeCoerce v)

76+-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object.

49unsafeToRawJSVal :: a -> JSVal

77unsafeToRawJSVal :: a -> JSVal

50unsafeToRawJSVal v = unsafeCoerce (Val v)

78unsafeToRawJSVal v = unsafeCoerce (Val v)

51#else

79#else

80+-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'

81+-- can be used to get the referred to value without fear of @Nothing@,

82+-- and 'getFastWeakTicketWeak' can be used to get the weak version.

52data FastWeakTicket a = FastWeakTicket

83data FastWeakTicket a = FastWeakTicket

53 { _fastWeakTicket_val :: !a

84 { _fastWeakTicket_val :: !a

54 , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)

85 , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)

55 }

86 }

88+-- | A reference to some value which can be garbage collected if there are only weak references to the value left.

89+--

90+-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.

91+--

92+-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket'

93+-- if the value hasn't been collected yet.

94+--

95+-- Synonymous with 'Weak'.

57type FastWeak a = Weak a

96type FastWeak a = Weak a

58#endif

97#endif

99+-- | Return the @a@ kept alive by the given 'FastWeakTicket'.

100+--

60−-- This needs to be in IO so we know that we've relinquished the ticket

101+-- This needs to be in IO so we know that we've relinquished the ticket.

61getFastWeakTicketValue :: FastWeakTicket a -> IO a

102getFastWeakTicketValue :: FastWeakTicket a -> IO a

62#ifdef GHCJS_FAST_WEAK

103#ifdef GHCJS_FAST_WEAK

63getFastWeakTicketValue t = do

104getFastWeakTicketValue t = do

@@ -69,6 +110,8 @@ foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a

69getFastWeakTicketValue = return . _fastWeakTicket_val

110getFastWeakTicketValue = return . _fastWeakTicket_val

70#endif

111#endif

112

113+-- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected,

114+-- or @Nothing@ if it has been collected.

72getFastWeakValue :: FastWeak a -> IO (Maybe a)

115getFastWeakValue :: FastWeak a -> IO (Maybe a)

73#ifdef GHCJS_FAST_WEAK

116#ifdef GHCJS_FAST_WEAK

74getFastWeakValue w = do

117getFastWeakValue w = do

@@ -84,6 +127,9 @@ foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.v

84getFastWeakValue = deRefWeak

127getFastWeakValue = deRefWeak

85#endif

128#endif

129

130+-- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred

131+-- remains alive. Returns @Just@ if the value hasn't been collected

132+-- and a ticket can therefore be obtained, @Nothing@ if it's been collected.

87getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

133getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

88#ifdef GHCJS_FAST_WEAK

134#ifdef GHCJS_FAST_WEAK

89getFastWeakTicket w = do

135getFastWeakTicket w = do

@@ -103,8 +149,11 @@ getFastWeakTicket w = do

103 }

149 }

104#endif

150#endif

105

151

106−-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the associated FastWeak to actually be weak

152+-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process

153+-- which can be obtained with 'getFastWeakTicketValue'.

107mkFastWeakTicket :: a -> IO (FastWeakTicket a)

154mkFastWeakTicket :: a -> IO (FastWeakTicket a)

155+-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the

156+-- associated FastWeak to actually be weak

108#ifdef GHCJS_FAST_WEAK

157#ifdef GHCJS_FAST_WEAK

109mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)

158mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)

110

159

@@ -119,11 +168,16 @@ mkFastWeakTicket v = do

119 }

168 }

120#endif

169#endif

121

170

171+-- | Demote a 'FastWeakTicket'; which ensures the value is alive, to a 'FastWeak' which doesn't.

172+-- Note that unless the ticket for the same 'FastWeak' is held in some other way

173+-- the value might be collected immediately.

174+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

122-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value

175-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value

123#ifdef GHCJS_FAST_WEAK

176#ifdef GHCJS_FAST_WEAK

124−foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

177+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a)

178+{-# INLINE getFastWeakTicketWeak #-}

179+getFastWeakTicketWeak = getFastWeakTicketWeak'

125#else

180#else

126−getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

127getFastWeakTicketWeak = return . _fastWeakTicket_weak

181getFastWeakTicketWeak = return . _fastWeakTicket_weak

128#endif

182#endif

129

183

@@ -133,7 +187,6 @@ emptyFastWeak = unsafeCoerce w

133 where w :: FastWeak Any

187 where w :: FastWeak Any

134#ifdef GHCJS_FAST_WEAK

188#ifdef GHCJS_FAST_WEAK

135 w = js_emptyWeak

189 w = js_emptyWeak

136−foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any

137#else

190#else

138 w = unsafePerformIO $ do

191 w = unsafePerformIO $ do

139 w' <- mkWeakPtr undefined Nothing

192 w' <- mkWeakPtr undefined Nothing

@@ -141,3 +194,7 @@ foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: Fa

141 return w'

194 return w'

142#endif

195#endif

143{-# NOINLINE emptyFastWeak #-}

196{-# NOINLINE emptyFastWeak #-}

197+

198+#ifdef GHCJS_FAST_WEAK

199+foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any

200+#endif

src/Reflex/FunctorMaybe.hs+30−18

@@ -1,33 +1,45 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE StandaloneDeriving #-}

5+-- |

6+-- Module:

7+-- Reflex.FunctorMaybe

8+-- Description:

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

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

2−-- ability to delete values.

10+-- ability to delete values.

3module Reflex.FunctorMaybe

11module Reflex.FunctorMaybe

4 ( FunctorMaybe (..)

12 ( FunctorMaybe (..)

5 ) where

13 ) where

7−import Data.Maybe

15+import Data.IntMap (IntMap)

16+import Data.Map (Map)

17+#if MIN_VERSION_base(4,9,0)

18+import Data.Semigroup (Option(..))

19+#endif

20+import Data.Witherable

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

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

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

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

12−-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the

25+-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@.

13−-- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@,

26+{-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-}

14−-- and e.g. 'Event' is instance of neither.

15−--

16−-- A definition of 'fmapMaybe' must satisfy the following laws:

17−--

18−-- [/identity/]

19−-- @'fmapMaybe' 'Just' ≡ 'id'@

20−--

21−-- [/composition/]

22−-- @'fmapMaybe' (f <=< g) ≡ 'fmapMaybe' f . 'fmapMaybe' g@

23class FunctorMaybe f where

27class FunctorMaybe f where

24 -- | Combined mapping and filtering function.

28 -- | Combined mapping and filtering function.

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

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

27−-- | @fmapMaybe = (=<<)

28instance FunctorMaybe Maybe where

31instance FunctorMaybe Maybe where

29− fmapMaybe = (=<<)

32+ fmapMaybe = mapMaybe

33+

34+#if MIN_VERSION_base(4,9,0)

35+deriving instance FunctorMaybe Option

36+#endif

31−-- | @fmapMaybe f = catMaybes . fmap f@

32instance FunctorMaybe [] where

38instance FunctorMaybe [] where

33− fmapMaybe f = catMaybes . fmap f

39+ fmapMaybe = mapMaybe

40+

41+instance FunctorMaybe (Map k) where

42+ fmapMaybe = mapMaybe

43+

44+instance FunctorMaybe IntMap where

45+ fmapMaybe = mapMaybe

src/Reflex/Host/Class.hs+6−25

@@ -30,38 +30,19 @@ module Reflex.Host.Class

31import Reflex.Class

33−import Control.Applicative

34−import Control.Monad

35import Control.Monad.Fix

33import Control.Monad.Fix

36import Control.Monad.Identity

34import Control.Monad.Identity

37import Control.Monad.Ref

35import Control.Monad.Ref

38import Control.Monad.Trans

36import Control.Monad.Trans

39−import Control.Monad.Trans.Cont (ContT ())

37+import Control.Monad.Trans.Cont (ContT)

40−import Control.Monad.Trans.Except (ExceptT ())

38+import Control.Monad.Trans.Except (ExceptT)

41−import Control.Monad.Trans.Reader (ReaderT ())

39+import Control.Monad.Trans.Reader (ReaderT)

42−import Control.Monad.Trans.RWS (RWST ())

40+import Control.Monad.Trans.RWS (RWST)

43−import Control.Monad.Trans.State (StateT ())

41+import Control.Monad.Trans.State (StateT)

44import qualified Control.Monad.Trans.State.Strict as Strict

42import qualified Control.Monad.Trans.State.Strict as Strict

45−import Control.Monad.Trans.Writer (WriterT ())

43+import Control.Monad.Trans.Writer (WriterT)

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

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

47import Data.GADT.Compare

45import Data.GADT.Compare

48−import Data.Monoid

49−

50−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

51−import Control.Monad.Primitive (touch)

52−import Data.IORef

53−import Reflex.Spider.Internal (EventM (..), HasSpiderTimeline, RootTrigger, SpiderEventHandle (..),

54− SpiderHost (..), SpiderHostFrame (..), Subscriber (..), newEventWithTriggerIO,

55− newFanEventWithTriggerIO, run, runFrame, scheduleClear, subscribe)

56−import qualified Reflex.Spider.Internal

57−#endif

58−

59−-- Note: this import must come last to silence warnings from AMP

60−import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

61−

62−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

63−#include "../Spider/SpiderTimelineHost.include.hs"

64−#endif

66-- | Framework implementation support class for the reflex implementation

47-- | Framework implementation support class for the reflex implementation

67-- represented by @t@.

48-- represented by @t@.

src/Reflex/Network.hs+14−9

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DefaultSignatures #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

2{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE FunctionalDependencies #-}

5#ifdef USE_REFLEX_OPTIMIZER

3#ifdef USE_REFLEX_OPTIMIZER

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

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

7#endif

5#endif

6+-- |

7+-- Module:

8+-- Reflex.Network

9+-- Description:

10+-- This module provides combinators for building FRP graphs/networks and modifying them dynamically.

8module Reflex.Network

11module Reflex.Network

9 ( networkView

12 ( networkView

10 , networkHold

13 , networkHold

@@ -12,29 +15,31 @@ module Reflex.Network

12 ) where

15 ) where

14import Reflex.Class

17import Reflex.Class

18+import Reflex.Adjustable.Class

15import Reflex.NotReady.Class

19import Reflex.NotReady.Class

16import Reflex.PostBuild.Class

20import Reflex.PostBuild.Class

18−-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.

22+-- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates.

19−-- The returned Event of network results occurs when the Dynamic does.

23+-- The returned Event of network results fires when the 'Dynamic' updates.

20−-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').

24+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires

25+-- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly').

21−networkView :: (Reflex t, NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

26+networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

22networkView child = do

27networkView child = do

23 postBuild <- getPostBuild

28 postBuild <- getPostBuild

24 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

29 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

25 snd <$> runWithReplace notReady newChild

30 snd <$> runWithReplace notReady newChild

27−-- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires.

32+-- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires.

28-- The returned Dynamic of network results occurs when the Event does.

33-- The returned Dynamic of network results occurs when the Event does.

29-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

34-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

30−networkHold :: (Reflex t, Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)

35+networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)

31networkHold child0 newChild = do

36networkHold child0 newChild = do

32 (result0, newResult) <- runWithReplace child0 newChild

37 (result0, newResult) <- runWithReplace child0 newChild

33 holdDyn result0 newResult

38 holdDyn result0 newResult

35-- | Render a placeholder network to be shown while another network is not yet

40-- | Render a placeholder network to be shown while another network is not yet

36-- done building

41-- done building

37−untilReady :: (Reflex t, Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)

42+untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)

38untilReady a b = do

43untilReady a b = do

39 postBuild <- getPostBuild

44 postBuild <- getPostBuild

40 runWithReplace a $ b <$ postBuild

45 runWithReplace a $ b <$ postBuild

src/Reflex/NotReady/Class.hs+17−6

@@ -1,9 +1,10 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DefaultSignatures #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE UndecidableInstances #-}

8{-# LANGUAGE UndecidableInstances #-}

8#ifdef USE_REFLEX_OPTIMIZER

9#ifdef USE_REFLEX_OPTIMIZER

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

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

@@ -12,17 +13,19 @@ module Reflex.NotReady.Class

12 ( NotReady(..)

13 ( NotReady(..)

13 ) where

14 ) where

15−import Control.Monad.Trans

16import Control.Monad.Reader (ReaderT)

17+import Control.Monad.Trans

18+import Control.Monad.Trans.Writer (WriterT)

20+import Reflex.BehaviorWriter.Base (BehaviorWriterT)

18import Reflex.Class

21import Reflex.Class

22+import Reflex.DynamicWriter.Base (DynamicWriterT)

23+import Reflex.EventWriter.Base (EventWriterT)

19import Reflex.Host.Class

24import Reflex.Host.Class

25+import Reflex.PerformEvent.Base (PerformEventT (..))

20import Reflex.PostBuild.Base (PostBuildT)

26import Reflex.PostBuild.Base (PostBuildT)

21−import Reflex.EventWriter (EventWriterT)

22−import Reflex.DynamicWriter (DynamicWriterT)

23import Reflex.Query.Base (QueryT)

27import Reflex.Query.Base (QueryT)

24import Reflex.Requester.Base (RequesterT)

28import Reflex.Requester.Base (RequesterT)

25−import Reflex.PerformEvent.Base (PerformEventT(..))

26import Reflex.TriggerEvent.Base (TriggerEventT)

29import Reflex.TriggerEvent.Base (TriggerEventT)

28class Monad m => NotReady t m | m -> t where

31class Monad m => NotReady t m | m -> t where

@@ -38,6 +41,10 @@ instance NotReady t m => NotReady t (ReaderT r m) where

38 notReadyUntil = lift . notReadyUntil

41 notReadyUntil = lift . notReadyUntil

39 notReady = lift notReady

42 notReady = lift notReady

44+instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where

45+ notReadyUntil = lift . notReadyUntil

46+ notReady = lift notReady

47+

41instance NotReady t m => NotReady t (PostBuildT t m) where

48instance NotReady t m => NotReady t (PostBuildT t m) where

42 notReadyUntil = lift . notReadyUntil

49 notReadyUntil = lift . notReadyUntil

43 notReady = lift notReady

50 notReady = lift notReady

@@ -50,6 +57,10 @@ instance NotReady t m => NotReady t (DynamicWriterT t w m) where

50 notReadyUntil = lift . notReadyUntil

57 notReadyUntil = lift . notReadyUntil

51 notReady = lift notReady

58 notReady = lift notReady

60+instance NotReady t m => NotReady t (BehaviorWriterT t w m) where

61+ notReadyUntil = lift . notReadyUntil

62+ notReady = lift notReady

63+

53instance NotReady t m => NotReady t (QueryT t q m) where

64instance NotReady t m => NotReady t (QueryT t q m) where

54 notReadyUntil = lift . notReadyUntil

65 notReadyUntil = lift . notReadyUntil

55 notReady = lift notReady

66 notReady = lift notReady

src/Reflex/Optimizer.hs+13−4

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

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.

5{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

6{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

4+-- |

5+-- Module:

6+-- Reflex.Optimizer

7+-- Description:

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

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

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

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

8module Reflex.Optimizer

12module Reflex.Optimizer

9 ( plugin

13 ( plugin

10 ) where

14 ) where

@@ -16,6 +20,11 @@ import Control.Arrow

16import CoreMonad

20import CoreMonad

17import Data.String

21import Data.String

18import GhcPlugins

22import GhcPlugins

23+

24+#if MIN_VERSION_base(4,9,0)

25+import Prelude hiding ((<>))

26+#endif

27+

19#endif

28#endif

21#ifdef ghcjs_HOST_OS

30#ifdef ghcjs_HOST_OS

src/Reflex/Patch.hs+20−8

@@ -1,6 +1,10 @@

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

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

3{-# LANGUAGE TypeFamilies #-}

1{-# LANGUAGE TypeFamilies #-}

2+-- |

3+-- Module:

4+-- Reflex.Patch

5+-- Description:

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

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

4module Reflex.Patch

8module Reflex.Patch

5 ( module Reflex.Patch

9 ( module Reflex.Patch

6 , module X

10 , module X

@@ -8,15 +12,18 @@ module Reflex.Patch

9import Reflex.Patch.Class as X

13import Reflex.Patch.Class as X

10import Reflex.Patch.DMap as X hiding (getDeletions)

14import Reflex.Patch.DMap as X hiding (getDeletions)

11−import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)

15+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,

12−import Reflex.Patch.Map as X

16+ patchDMapWithMoveToPatchMapWithMoveWith,

13−import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElementsMap, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

17+ traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,

18+ unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)

14import Reflex.Patch.IntMap as X hiding (getDeletions)

19import Reflex.Patch.IntMap as X hiding (getDeletions)

15−

20+import Reflex.Patch.Map as X

21+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,

22+ patchMapWithMoveNewElementsMap, unPatchMapWithMove,

23+ unsafePatchMapWithMove)

24+import Data.Map.Monoidal (MonoidalMap)

16import Data.Semigroup (Semigroup (..), (<>))

25import Data.Semigroup (Semigroup (..), (<>))

18−---- Patches based on commutative groups

19−

20-- | A 'Group' is a 'Monoid' where every element has an inverse.

27-- | A 'Group' is a 'Monoid' where every element has an inverse.

21class (Semigroup q, Monoid q) => Group q where

28class (Semigroup q, Monoid q) => Group q where

22 negateG :: q -> q

29 negateG :: q -> q

@@ -32,3 +39,8 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

32instance Additive p => Patch (AdditivePatch p) where

39instance Additive p => Patch (AdditivePatch p) where

33 type PatchTarget (AdditivePatch p) = p

40 type PatchTarget (AdditivePatch p) = p

34 apply (AdditivePatch p) q = Just $ p <> q

41 apply (AdditivePatch p) q = Just $ p <> q

42+

43+instance (Ord k, Group q) => Group (MonoidalMap k q) where

44+ negateG = fmap negateG

45+

46+instance (Ord k, Additive q) => Additive (MonoidalMap k q)

src/Reflex/Patch/Class.hs+12

@@ -4,8 +4,12 @@ module Reflex.Patch.Class where

5import Control.Monad.Identity

6import Data.Maybe

7+import Data.Semigroup (Semigroup(..))

8-- | A 'Patch' type represents a kind of change made to a datastructure.

9-- | A 'Patch' type represents a kind of change made to a datastructure.

10+--

11+-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey

12+-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.

9class Patch p where

13class Patch p where

10 type PatchTarget p :: *

14 type PatchTarget p :: *

11 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return

15 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return

@@ -20,3 +24,11 @@ applyAlways p t = fromMaybe t $ apply p t

20instance Patch (Identity a) where

24instance Patch (Identity a) where

21 type PatchTarget (Identity a) = a

25 type PatchTarget (Identity a) = a

22 apply (Identity a) _ = Just a

26 apply (Identity a) _ = Just a

27+

28+-- | Like '(.)', but composes functions that return patches rather than

29+-- functions that return new values. The Semigroup instance for patches must

30+-- apply patches right-to-left, like '(.)'.

31+composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p

32+composePatchFunctions g f a =

33+ let fp = f a

34+ in g (applyAlways fp a) <> fp

src/Reflex/Patch/DMap.hs+23−9

@@ -5,6 +5,7 @@

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE StandaloneDeriving #-}

7{-# LANGUAGE TypeFamilies #-}

8+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

8module Reflex.Patch.DMap where

9module Reflex.Patch.DMap where

10import Reflex.Patch.Class

11import Reflex.Patch.Class

@@ -14,20 +15,22 @@ import Reflex.Patch.Map

14import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

15import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

15import qualified Data.Dependent.Map as DMap

16import qualified Data.Dependent.Map as DMap

16import Data.Functor.Constant

17import Data.Functor.Constant

17−import qualified Data.IntMap as IntMap

18import Data.Functor.Misc

19+import qualified Data.IntMap as IntMap

19import qualified Data.Map as Map

20import qualified Data.Map as Map

20import Data.Semigroup (Semigroup (..))

21import Data.Semigroup (Semigroup (..))

21import Data.Some (Some)

22import Data.Some (Some)

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

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

24−-- deleted.

25+-- Insertions are represented as @'ComposeMaybe' (Just value)@,

26+-- while deletions are represented as @'ComposeMaybe' Nothing@.

25newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }

27newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }

27deriving instance GCompare k => Semigroup (PatchDMap k v)

29deriving instance GCompare k => Semigroup (PatchDMap k v)

29deriving instance GCompare k => Monoid (PatchDMap k v)

31deriving instance GCompare k => Monoid (PatchDMap k v)

33+-- | Apply the insertions or deletions to a given 'DMap'.

31instance GCompare k => Patch (PatchDMap k v) where

34instance GCompare k => Patch (PatchDMap k v) where

32 type PatchTarget (PatchDMap k v) = DMap k v

35 type PatchTarget (PatchDMap k v) = DMap k v

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

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

@@ -37,32 +40,43 @@ instance GCompare k => Patch (PatchDMap k v) where

37 Nothing -> Just $ Constant ()

40 Nothing -> Just $ Constant ()

38 Just _ -> Nothing

41 Just _ -> Nothing

43+-- | Map a function @v a -> v' a@ over any inserts/updates in the given

44+-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.

40mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'

45mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'

41mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p

46mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p

48+-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given

49+-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.

43−traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

50+traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')

44traversePatchDMap f = traversePatchDMapWithKey $ const f

51traversePatchDMap f = traversePatchDMapWithKey $ const f

53+-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates

54+-- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.

46traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

55traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

47traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p

56traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p

58+-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function

59+-- @v a -> v'@ to weaken each value contained in the patch.

49weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'

60weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'

50weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p

61weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p

63+-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of

64+-- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@.

52−patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'

65+patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'

53patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p

66patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p

68+-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.

55−const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f

69+const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'

56const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

70const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

57− where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)

71+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')

58 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

72 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

74+-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.

60const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f

75const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f

61const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p

76const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p

62 where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)

77 where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)

63 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

78 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

65−-- | Get the values that will be deleted if the given patch is applied to the

80+-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.

66−-- given 'DMap'. Includes values that will be replaced.

67getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'

81getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'

68getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p

82getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p

src/Reflex/Patch/DMapWithMove.hs+136−53

@@ -10,6 +10,9 @@

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

13+

14+-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and

15+-- move values between keys.

13module Reflex.Patch.DMapWithMove where

16module Reflex.Patch.DMapWithMove where

15import Reflex.Patch.Class

18import Reflex.Patch.Class

@@ -23,6 +26,7 @@ import Data.Functor.Constant

23import Data.Functor.Misc

26import Data.Functor.Misc

24import Data.Functor.Product

27import Data.Functor.Product

25import Data.GADT.Compare (GEq (..))

28import Data.GADT.Compare (GEq (..))

29+import Data.GADT.Show (GShow, gshow)

26import qualified Data.Map as Map

30import qualified Data.Map as Map

27import Data.Maybe

31import Data.Maybe

28import Data.Semigroup (Semigroup (..), (<>))

32import Data.Semigroup (Semigroup (..), (<>))

@@ -30,65 +34,91 @@ import Data.Some (Some)

30import qualified Data.Some as Some

34import qualified Data.Some as Some

31import Data.These

35import Data.These

33−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

34−import Data.Dependent.Sum (ShowTag (..))

35−import Data.GADT.Show (GShow (..))

36−import Data.Typeable (Proxy (..))

37−#endif

38−

39−-- | Like 'PatchMapWithMove', but for 'DMap'.

37+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and

38+-- destinations.

39+--

40+-- Invariants:

41+--

42+-- * A key should not move to itself.

43+-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)

40newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

44newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

41−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

42− deriving (Show)

43−#endif

46+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key

47+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.

45data NodeInfo k v a = NodeInfo

48data NodeInfo k v a = NodeInfo

46 { _nodeInfo_from :: !(From k v a)

49 { _nodeInfo_from :: !(From k v a)

50+ -- ^Change applying to the current key, be it an insert, move, or delete.

47 , _nodeInfo_to :: !(To k a)

51 , _nodeInfo_to :: !(To k a)

52+ -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.

48 }

53 }

49 deriving (Show)

54 deriving (Show)

51−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

56+-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a

52−instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (NodeInfo k v) where

57+-- key (@From_Delete@), or moving a key (@From_Move@).

53− showTagToShow k _ r = gshowToShow k $ showTagToShow k (Proxy :: Proxy v) r

54−

55−instance {-# INCOHERENT #-} (GEq k, EqTag k v) => EqTag k (From k v) where

56− eqTagToEq k _ r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)

57−#endif

58−

59data From (k :: a -> *) (v :: a -> *) :: a -> * where

58data From (k :: a -> *) (v :: a -> *) :: a -> * where

59+ -- |Insert a new or update an existing key with the given value @v a@

60 From_Insert :: v a -> From k v a

61+ -- |Delete the existing key

61 From_Delete :: From k v a

62 From_Delete :: From k v a

63+ -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,

64+ -- usually but not necessarily with @From_Delete@.

62 From_Move :: !(k a) -> From k v a

65 From_Move :: !(k a) -> From k v a

63 deriving (Show, Read, Eq, Ord)

66 deriving (Show, Read, Eq, Ord)

68+-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other

69+-- operation.

65type To = ComposeMaybe

70type To = ComposeMaybe

72+-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.

67−validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool

73+validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool

68−validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst

74+validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

69− where

70− src = DMap.map _nodeInfo_to m

71− dst = DMap.map _nodeInfo_from m

72− srcFromDst :: DMap k (ComposeMaybe k)

73− srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of

74− From_Move from -> from :=> ComposeMaybe (Just to)

75− _ -> to :=> ComposeMaybe Nothing

76+-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.

77+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]

78+validationErrorsForPatchDMapWithMove m =

79+ noSelfMoves <> movesBalanced

80+ where

81+ noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

82+ selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"

83+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"

84+ selfMove _ = Nothing

85+ movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

86+ unbalancedMove (dst :=> NodeInfo (From_Move src) _) =

87+ case DMap.lookup src m of

88+ Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"

89+ Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->

90+ if isNothing (dst' `geq` dst)

91+ then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"

92+ else Nothing

93+ _ ->

94+ Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"

95+ unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =

96+ case DMap.lookup dst m of

97+ Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"

98+ Just (NodeInfo (From_Move src') _) ->

99+ if isNothing (src' `geq` src)

100+ then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"

101+ else Nothing

102+

103+ _ ->

104+ Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"

105+ unbalancedMove _ = Nothing

106+

107+-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.

77instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where

108instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where

78 PatchDMapWithMove a == PatchDMapWithMove b = a == b

109 PatchDMapWithMove a == PatchDMapWithMove b = a == b

110

111+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9

80data Pair1 f g a = Pair1 (f a) (g a)

112data Pair1 f g a = Pair1 (f a) (g a)

113

82−instance GCompare k => Semigroup (PatchDMapWithMove k v) where

114+-- |Helper data structure used for composing patches using the monoid instance.

83− (<>) = mappend

84−

85data Fixup k v a

115data Fixup k v a

86 = Fixup_Delete

116 = Fixup_Delete

87 | Fixup_Update (These (From k v a) (To k a))

117 | Fixup_Update (These (From k v a) (To k a))

118

119+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

89−instance GCompare k => Monoid (PatchDMapWithMove k v) where

120+instance GCompare k => Semigroup (PatchDMapWithMove k v) where

90− mempty = PatchDMapWithMove mempty

91− PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m

121+ PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

92 where

122 where

93 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb

123 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb

94 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]

124 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]

@@ -122,18 +152,21 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where

122 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

152 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

123 }

153 }

124 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups

154 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups

125−

126−getHere :: These a b -> Maybe a

155+ getHere :: These a b -> Maybe a

127−getHere = \case

156+ getHere = \case

128− This a -> Just a

157+ This a -> Just a

129− These a _ -> Just a

158+ These a _ -> Just a

130− That _ -> Nothing

159+ That _ -> Nothing

131−

132−getThere :: These a b -> Maybe b

160+ getThere :: These a b -> Maybe b

133−getThere = \case

161+ getThere = \case

134− This _ -> Nothing

162+ This _ -> Nothing

135− These _ b -> Just b

163+ These _ b -> Just b

136− That b -> Just b

164+ That b -> Just b

165+

166+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

167+instance GCompare k => Monoid (PatchDMapWithMove k v) where

168+ mempty = PatchDMapWithMove mempty

169+ mappend = (<>)

137

170

138{-

171{-

139mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v

172mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v

@@ -157,6 +190,16 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith

157 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore

190 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore

158-}

191-}

159

192

193+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.

194+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v

195+insertDMapKey k v =

196+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)

197+

198+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:

199+--

200+-- @

201+-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))

202+-- @

160moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

203moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

161moveDMapKey src dst = case src `geq` dst of

204moveDMapKey src dst = case src `geq` dst of

162 Nothing -> PatchDMapWithMove $ DMap.fromList

205 Nothing -> PatchDMapWithMove $ DMap.fromList

@@ -165,6 +208,24 @@ moveDMapKey src dst = case src `geq` dst of

165 ]

208 ]

166 Just _ -> mempty

209 Just _ -> mempty

167

210

211+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

212+--

213+-- @

214+-- let aMay = DMap.lookup a dmap

215+-- bMay = DMap.lookup b dmap

216+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)

217+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)

218+-- . DMap.delete a . DMap.delete b $ dmap

219+-- @

220+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

221+swapDMapKey src dst = case src `geq` dst of

222+ Nothing -> PatchDMapWithMove $ DMap.fromList

223+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)

224+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)

225+ ]

226+ Just _ -> mempty

227+

228+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.

168deleteDMapKey :: k a -> PatchDMapWithMove k v

229deleteDMapKey :: k a -> PatchDMapWithMove k v

169deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing

230deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing

170

231

@@ -192,14 +253,25 @@ dst (PatchDMapWithMove x _) = x

192src (PatchDMapWithMove _ x) = x

253src (PatchDMapWithMove _ x) = x

193-}

254-}

194

255

256+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.

195unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

257unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

196unPatchDMapWithMove (PatchDMapWithMove p) = p

258unPatchDMapWithMove (PatchDMapWithMove p) = p

197

259

260+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.

261+--

198−-- | Warning: when using this function, you must ensure that the invariants of

262+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.

199−-- 'PatchDMapWithMove' are preserved; they will not be checked.

200unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

263unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

201unsafePatchDMapWithMove = PatchDMapWithMove

264unsafePatchDMapWithMove = PatchDMapWithMove

202

265

266+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned

267+-- otherwise @Left errors@.

268+patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)

269+patchDMapWithMove dm =

270+ case validationErrorsForPatchDMapWithMove dm of

271+ [] -> Right $ unsafePatchDMapWithMove dm

272+ errs -> Left errs

273+

274+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.

203mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'

275mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'

204mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

276mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

205 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p

277 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p

@@ -209,9 +281,11 @@ mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

209 From_Delete -> From_Delete

281 From_Delete -> From_Delete

210 From_Move k -> From_Move k

282 From_Move k -> From_Move k

211

283

284+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.

212traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

285traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

213traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

286traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

214

287

288+-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.

215traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

289traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

216traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

290traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

217 where g :: forall a. k a -> From k v a -> m (From k v' a)

291 where g :: forall a. k a -> From k v a -> m (From k v' a)

@@ -220,12 +294,16 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$>

220 From_Delete -> pure From_Delete

294 From_Delete -> pure From_Delete

221 From_Move fromKey -> pure $ From_Move fromKey

295 From_Move fromKey -> pure $ From_Move fromKey

222

296

297+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.

223nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

298nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

224nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

299nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

225

300

301+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.

226nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

302nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

227nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

303nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

228

304

305+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to

306+-- values.

229weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

307weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

230weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

308weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

231 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'

309 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'

@@ -237,9 +315,11 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD

237 , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)

315 , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)

238 }

316 }

239

317

318+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any

319+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.

240−patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'

320+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'

241patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

321patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

242− where g :: NodeInfo (Const2 k v) f v -> MapWithMove.NodeInfo k v'

322+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'

243 g ni = MapWithMove.NodeInfo

323 g ni = MapWithMove.NodeInfo

244 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

245 From_Insert v -> MapWithMove.From_Insert $ f v

325 From_Insert v -> MapWithMove.From_Insert $ f v

@@ -248,9 +328,12 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo

248 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

328 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

249 }

329 }

250

330

331+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed

332+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.

333+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

251−const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f

334+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'

252const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

335const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

253− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) f)

336+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')

254 g (k, ni) = Const2 k :=> NodeInfo

337 g (k, ni) = Const2 k :=> NodeInfo

255 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

338 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

256 MapWithMove.From_Insert v -> From_Insert $ f v

339 MapWithMove.From_Insert v -> From_Insert $ f v

@@ -259,6 +342,7 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr

259 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

342 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

260 }

343 }

261

344

345+-- | Apply the insertions, deletions, and moves to a given 'DMap'.

262instance GCompare k => Patch (PatchDMapWithMove k v) where

346instance GCompare k => Patch (PatchDMapWithMove k v) where

263 type PatchTarget (PatchDMapWithMove k v) = DMap k v

347 type PatchTarget (PatchDMapWithMove k v) = DMap k v

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

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

@@ -274,8 +358,7 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where

274 From_Delete -> Just $ Constant ()

358 From_Delete -> Just $ Constant ()

275 _ -> Nothing

359 _ -> Nothing

276

360

277−-- | Get the values that will be deleted or moved if the given patch is applied

361+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.

278−-- to the given 'DMap'.

279getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

362getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

280getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

363getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

281 where f _ v ni = Pair v $ _nodeInfo_to ni

364 where f _ v ni = Pair v $ _nodeInfo_to ni

src/Reflex/Patch/IntMap.hs+20−3

@@ -1,20 +1,25 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveFoldable #-}

2{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveTraversable #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE TypeFamilies #-}

7+-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for

8+-- insert/update or delete of associations.

7module Reflex.Patch.IntMap where

9module Reflex.Patch.IntMap where

9−import Prelude hiding (lookup)

10import Data.IntMap.Strict (IntMap)

11import Data.IntMap.Strict (IntMap)

11import qualified Data.IntMap.Strict as IntMap

12import qualified Data.IntMap.Strict as IntMap

12import Data.Maybe

13import Data.Maybe

13import Data.Semigroup

14import Data.Semigroup

14import Reflex.Patch.Class

15import Reflex.Patch.Class

17+-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.

18+-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update

19+-- and @Nothing@ means delete.

16newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

20newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

22+-- | Apply the insertions or deletions to a given 'IntMap'.

18instance Patch (PatchIntMap a) where

23instance Patch (PatchIntMap a) where

19 type PatchTarget (PatchIntMap a) = IntMap a

24 type PatchTarget (PatchIntMap a) = IntMap a

20 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

25 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

@@ -37,14 +42,26 @@ instance Semigroup (PatchIntMap v) where

37 GT -> x

42 GT -> x

38#endif

43#endif

45+-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@

46+-- (that is, all inserts/updates), producing a @PatchIntMap b@.

47+mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b

48+mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m

49+

50+-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@

51+-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.

40−traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)

52+traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)

41traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

53traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

55+-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.

43patchIntMapNewElements :: PatchIntMap a -> [a]

56patchIntMapNewElements :: PatchIntMap a -> [a]

44patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

57patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

59+-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all

60+-- the inserts/updates in the given patch.

46patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

61patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

47patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

62patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

64+-- | Subset the given @'IntMap' a@ to contain only the keys that would be

65+-- deleted by the given @'PatchIntMap' a@.

49getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

66getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

50getDeletions (PatchIntMap m) v = IntMap.intersection v m

67getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Reflex/Patch/Map.hs+2−3

@@ -7,10 +7,10 @@ module Reflex.Patch.Map where

8import Reflex.Patch.Class

10−import Data.Semigroup

11import Data.Map (Map)

10import Data.Map (Map)

12import qualified Data.Map as Map

11import qualified Data.Map as Map

13import Data.Maybe

12import Data.Maybe

13+import Data.Semigroup

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

16-- deleted. Insertions are represented as values wrapped in 'Just', while

@@ -18,8 +18,7 @@ import Data.Maybe

18newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

19 deriving (Show, Read, Eq, Ord)

21−-- | Applying a 'PatchMap' will update the 'Map' by performing the insertions

21+-- | Apply the insertions or deletions to a given 'Map'.

22−-- and deletions specified

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

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

24 type PatchTarget (PatchMap k v) = Map k v

23 type PatchTarget (PatchMap k v) = Map k v

25 {-# INLINABLE apply #-}

24 {-# INLINABLE apply #-}

src/Reflex/Patch/MapWithMove.hs+134−20

@@ -3,6 +3,7 @@

3{-# LANGUAGE DeriveTraversable #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE PatternGuards #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

8-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

9-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

@@ -19,7 +20,9 @@ import Data.List

19import Data.Map (Map)

20import Data.Map (Map)

20import qualified Data.Map as Map

21import qualified Data.Map as Map

21import Data.Maybe

22import Data.Maybe

23+import Data.Semigroup (Semigroup (..), (<>))

22import qualified Data.Set as Set

24import qualified Data.Set as Set

25+import Data.These (These(..))

23import Data.Tuple

26import Data.Tuple

25-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@

28-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@

@@ -38,6 +41,18 @@ data NodeInfo k v = NodeInfo

38 }

41 }

39 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

42 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

44+-- | Describe how a key's new value should be produced

45+data From k v

46+ = From_Insert v -- ^ Insert the given value here

47+ | From_Delete -- ^ Delete the existing value, if any, from here

48+ | From_Move !k -- ^ Move the value here from the given key

49+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

50+

51+-- | Describe where a key's old value will go. If this is 'Just', that means

52+-- the key's old value will be moved to the given other key; if it is 'Nothing',

53+-- that means it will be deleted.

54+type To = Maybe

55+

41-- | Create a 'PatchMapWithMove', validating it

56-- | Create a 'PatchMapWithMove', validating it

42patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)

57patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)

43patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

58patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

@@ -48,26 +63,62 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

48 From_Move from -> Just (from, to)

63 From_Move from -> Just (from, to)

49 _ -> Nothing

64 _ -> Nothing

66+-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'

67+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v

68+patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo

69+ { _nodeInfo_from = From_Insert v

70+ , _nodeInfo_to = Nothing

71+ }

72+

51-- | Extract the internal representation of the 'PatchMapWithMove'

73-- | Extract the internal representation of the 'PatchMapWithMove'

52unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

74unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

53unPatchMapWithMove (PatchMapWithMove p) = p

75unPatchMapWithMove (PatchMapWithMove p) = p

55−-- | Warning: when using this function, you must ensure that the invariants of

77+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.

56−-- 'PatchMapWithMove' are preserved; they will not be checked.

78+insertMapKey :: k -> v -> PatchMapWithMove k v

57−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

79+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

58−unsafePatchMapWithMove = PatchMapWithMove

60−-- | Describe how a key's new value should be produced

81+-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:

61−data From k v

82+--

62− = From_Insert v -- ^ Insert the given value here

83+-- @

63− | From_Delete -- ^ Delete the existing value, if any, from here

84+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

64− | From_Move !k -- ^ Move the value here from the given key

85+-- @

65− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

86+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v

87+moveMapKey src dst

88+ | src == dst = mempty

89+ | otherwise =

90+ PatchMapWithMove $ Map.fromList

91+ [ (dst, NodeInfo (From_Move src) Nothing)

92+ , (src, NodeInfo From_Delete (Just dst))

93+ ]

67−-- | Describe where a key's old value will go. If this is 'Just', that means

95+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

68−-- the key's old value will be moved to the given other key; if it is 'Nothing',

96+--

69−-- that means it will be deleted.

97+-- @

70−type To = Maybe

98+-- let aMay = Map.lookup a map

99+-- bMay = Map.lookup b map

100+-- in maybe id (Map.insert a) (bMay `mplus` aMay)

101+-- . maybe id (Map.insert b) (aMay `mplus` bMay)

102+-- . Map.delete a . Map.delete b $ map

103+-- @

104+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v

105+swapMapKey src dst

106+ | src == dst = mempty

107+ | otherwise =

108+ PatchMapWithMove $ Map.fromList

109+ [ (dst, NodeInfo (From_Move src) (Just src))

110+ , (src, NodeInfo (From_Move dst) (Just dst))

111+ ]

112+

113+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.

114+deleteMapKey :: k -> PatchMapWithMove k v

115+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing

116+

117+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.

118+--

119+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.

120+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

121+unsafePatchMapWithMove = PatchMapWithMove

122

72-- | Apply the insertions, deletions, and moves to a given 'Map'

123-- | Apply the insertions, deletions, and moves to a given 'Map'

73instance Ord k => Patch (PatchMapWithMove k v) where

124instance Ord k => Patch (PatchMapWithMove k v) where

@@ -81,10 +132,11 @@ instance Ord k => Patch (PatchMapWithMove k v) where

81 From_Delete -> Just ()

132 From_Delete -> Just ()

82 _ -> Nothing

133 _ -> Nothing

134

84−-- | Returns all the new elements that will be added to the 'Map'

135+-- | Returns all the new elements that will be added to the 'Map'.

85patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

136patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

86patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

137patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

138

139+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.

88patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

140patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

89patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

141patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

90 where f ni = case _nodeInfo_from ni of

142 where f ni = case _nodeInfo_from ni of

@@ -110,11 +162,15 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW

110-- will produce a 'Map' with the same values as the second 'Map' but with the

162-- will produce a 'Map' with the same values as the second 'Map' but with the

111-- values sorted with the given ordering function.

163-- values sorted with the given ordering function.

112patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

164patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

113−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch

165+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

114− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

115− newList = Map.toList newByIndexUnsorted

166+ where newList = Map.toList newByIndexUnsorted

116 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

167 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

117− insertsAndMoves :: Map k (NodeInfo k v)

168+

169+-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

170+-- will produce the second 'Map'.

171+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v

172+patchThatChangesMap oldByIndex newByIndex = patch

173+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

118 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

174 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

119 let f k v = do

175 let f k v = do

120 remainingValues <- get

176 remainingValues <- get

@@ -129,7 +185,7 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch

129 putRemainingKeys $ Set.delete k fromKs

185 putRemainingKeys $ Set.delete k fromKs

130 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

186 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

131 else do

187 else do

132− Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

188+ (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

133 putRemainingKeys remainingKeys

189 putRemainingKeys remainingKeys

134 return $ NodeInfo (From_Move fromK) $ Just undefined

190 return $ NodeInfo (From_Move fromK) $ Just undefined

135 Map.traverseWithKey f newByIndex

191 Map.traverseWithKey f newByIndex

@@ -154,3 +210,61 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _

154-- | Set the 'To' field of a 'NodeInfo'

210-- | Set the 'To' field of a 'NodeInfo'

155nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

211nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

156nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

212nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

213+

214+-- |Helper data structure used for composing patches using the monoid instance.

215+data Fixup k v

216+ = Fixup_Delete

217+ | Fixup_Update (These (From k v) (To k))

218+

219+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

220+instance Ord k => Semigroup (PatchMapWithMove k v) where

221+ PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

222+ where

223+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

224+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]

225+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

226+ (Just toAfter, From_Move fromBefore)

227+ | fromBefore == toAfter

228+ -> [(toAfter, Fixup_Delete)]

229+ | otherwise

230+ -> [ (toAfter, Fixup_Update (This editBefore))

231+ , (fromBefore, Fixup_Update (That mToAfter))

232+ ]

233+ (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

234+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

235+ (Nothing, _) -> []

236+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

237+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)

238+ | This x <- a, That y <- b

239+ = Fixup_Update $ These x y

240+ | That y <- a, This x <- b

241+ = Fixup_Update $ These x y

242+ mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"

243+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections

244+ combineNodeInfos _ nia nib = NodeInfo

245+ { _nodeInfo_from = _nodeInfo_from nia

246+ , _nodeInfo_to = _nodeInfo_to nib

247+ }

248+ applyFixup _ ni = \case

249+ Fixup_Delete -> Nothing

250+ Fixup_Update u -> Just $ NodeInfo

251+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u

252+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

253+ }

254+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

255+ getHere :: These a b -> Maybe a

256+ getHere = \case

257+ This a -> Just a

258+ These a _ -> Just a

259+ That _ -> Nothing

260+ getThere :: These a b -> Maybe b

261+ getThere = \case

262+ This _ -> Nothing

263+ These _ b -> Just b

264+ That b -> Just b

265+

266+--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here

267+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

268+instance Ord k => Monoid (PatchMapWithMove k v) where

269+ mempty = PatchMapWithMove mempty

270+ mappend = (<>)

src/Reflex/PerformEvent/Base.hs+4−3

@@ -25,6 +25,7 @@ module Reflex.PerformEvent.Base

25 ) where

27import Reflex.Class

28+import Reflex.Adjustable.Class

28import Reflex.Host.Class

29import Reflex.Host.Class

29import Reflex.PerformEvent.Class

30import Reflex.PerformEvent.Class

30import Reflex.Requester.Base

31import Reflex.Requester.Base

@@ -60,14 +61,14 @@ deriving instance ReflexHost t => Monad (PerformEventT t m)

60deriving instance ReflexHost t => MonadFix (PerformEventT t m)

61deriving instance ReflexHost t => MonadFix (PerformEventT t m)

61deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

62deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

62deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

63deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

63−deriving instance (ReflexHost t, Applicative m, Monoid a) => Monoid (PerformEventT t m a)

64+deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)

64−deriving instance (ReflexHost t, Applicative m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)

65+deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)

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

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

67 type PrimState (PerformEventT t m) = PrimState (HostFrame t)

68 type PrimState (PerformEventT t m) = PrimState (HostFrame t)

68 primitive = PerformEventT . lift . primitive

69 primitive = PerformEventT . lift . primitive

70−instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where

71+instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where

71 type Performable (PerformEventT t m) = HostFrame t

72 type Performable (PerformEventT t m) = HostFrame t

72 {-# INLINABLE performEvent_ #-}

73 {-# INLINABLE performEvent_ #-}

73 performEvent_ = PerformEventT . requesting_

74 performEvent_ = PerformEventT . requesting_

src/Reflex/PostBuild/Base.hs+2−1

@@ -23,6 +23,7 @@ module Reflex.PostBuild.Base

23 ) where

25import Reflex.Class

26+import Reflex.Adjustable.Class

26import Reflex.Host.Class

27import Reflex.Host.Class

27import Reflex.PerformEvent.Class

28import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Class

29import Reflex.PostBuild.Class

@@ -151,7 +152,7 @@ mapIntMapWithAdjustImpl base f dm0 dm' = do

151 rec (result0, result') <- base f' loweredDm0 loweredDm'

152 rec (result0, result') <- base f' loweredDm0 loweredDm'

152 cohortDone <- numberOccurrencesFrom_ 1 result'

153 cohortDone <- numberOccurrencesFrom_ 1 result'

153 numberedDm' <- numberOccurrencesFrom 1 dm'

154 numberedDm' <- numberOccurrencesFrom 1 dm'

154− let postBuild' = fanInt $ fmapCheap (\n -> IntMap.singleton n ()) cohortDone

155+ let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone

155 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do

156 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do

156 return $ fmap ((,) (selectInt postBuild' n)) p

157 return $ fmap ((,) (selectInt postBuild' n)) p

157 return (result0, result')

158 return (result0, result')

src/Reflex/Profiled.hs+19−5

@@ -1,4 +1,5 @@

1{-# LANGUAGE EmptyDataDecls #-}

2+{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE InstanceSigs #-}

5{-# LANGUAGE InstanceSigs #-}

@@ -7,10 +8,17 @@

7{-# LANGUAGE StandaloneDeriving #-}

8{-# LANGUAGE StandaloneDeriving #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE UndecidableInstances #-}

10{-# LANGUAGE UndecidableInstances #-}

11+-- |

12+-- Module:

13+-- Reflex.Profiled

14+-- Description:

15+-- This module contains an instance of the 'Reflex' class that provides

16+-- profiling/cost-center information.

10module Reflex.Profiled where

17module Reflex.Profiled where

12import Control.Lens hiding (children)

19import Control.Lens hiding (children)

13import Control.Monad

20import Control.Monad

21+import Control.Monad.Exception

14import Control.Monad.Fix

22import Control.Monad.Fix

15import Control.Monad.Primitive

23import Control.Monad.Primitive

16import Control.Monad.Reader

24import Control.Monad.Reader

@@ -18,21 +26,22 @@ import Control.Monad.Ref

18import Control.Monad.State.Strict (StateT, execStateT, modify)

26import Control.Monad.State.Strict (StateT, execStateT, modify)

19import Data.Coerce

27import Data.Coerce

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

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

21−import Data.List

22import Data.FastMutableIntMap

29import Data.FastMutableIntMap

23import Data.IORef

30import Data.IORef

31+import Data.List

24import Data.Map (Map)

32import Data.Map (Map)

25import qualified Data.Map.Strict as Map

33import qualified Data.Map.Strict as Map

26−import Data.Monoid

34+import Data.Monoid ((<>))

27import Data.Ord

35import Data.Ord

36+import qualified Data.Semigroup as S

28import Data.Type.Coercion

37import Data.Type.Coercion

29import Foreign.Ptr

38import Foreign.Ptr

30import GHC.Foreign

39import GHC.Foreign

31import GHC.IO.Encoding

40import GHC.IO.Encoding

32import GHC.Stack

41import GHC.Stack

33import Reflex.Class

42import Reflex.Class

34−import Reflex.PerformEvent.Class

35import Reflex.Host.Class

43import Reflex.Host.Class

44+import Reflex.PerformEvent.Class

37import System.IO.Unsafe

46import System.IO.Unsafe

38import Unsafe.Coerce

47import Unsafe.Coerce

@@ -50,9 +59,13 @@ data CostCentreTree = CostCentreTree

50 }

59 }

51 deriving (Show, Eq, Ord)

60 deriving (Show, Eq, Ord)

62+instance S.Semigroup CostCentreTree where

63+ (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =

64+ CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb

65+

53instance Monoid CostCentreTree where

66instance Monoid CostCentreTree where

54 mempty = CostCentreTree 0 0 mempty

67 mempty = CostCentreTree 0 0 mempty

55− CostCentreTree oa ea ca `mappend` CostCentreTree ob eb cb = CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (<>) ca cb

68+ mappend = (S.<>)

57getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]

70getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]

58getCostCentreStack = go []

71getCostCentreStack = go []

@@ -95,7 +108,8 @@ writeProfilingData :: FilePath -> IO ()

95writeProfilingData p = do

108writeProfilingData p = do

96 writeFile p =<< formatCostCentreTree =<< getCostCentreTree

109 writeFile p =<< formatCostCentreTree =<< getCostCentreTree

110

98−newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)

111+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }

112+ deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)

113

100profileEvent :: Reflex t => Event t a -> Event t a

114profileEvent :: Reflex t => Event t a -> Event t a

101profileEvent e = unsafePerformIO $ do

115profileEvent e = unsafePerformIO $ do

src/Reflex/Pure.hs+11−9

@@ -13,11 +13,13 @@

13-- * MonadSample (Pure t) ((->) t)

14-- * MonadHold (Pure t) ((->) t)

15{-# OPTIONS_GHC -fno-warn-orphans #-}

16−

16+-- |

17+-- Module: Reflex.Pure

18+-- Description:

17−-- | This module provides a pure implementation of Reflex, which is intended to

19+-- This module provides a pure implementation of Reflex, which is intended to

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

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

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

21+-- implementations of Reflex should produce the same results as this

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

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

21module Reflex.Pure

23module Reflex.Pure

22 ( Pure

24 ( Pure

23 , Behavior (..)

25 , Behavior (..)

@@ -43,12 +45,12 @@ import Data.Type.Coercion

43import Reflex.Class

45import Reflex.Class

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

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

46−-- with the type @t@.

48+-- with the type @/t/@.

47data Pure t

49data Pure t

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

51+-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

50−-- any y :: t such that pred x < y < x. The HasTrie instance will be used

52+-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

51−-- exclusively to memoize functions of t, not for any of its other capabilities.

53+-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.

52instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

54instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

54 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

56 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

src/Reflex/Query/Base.hs+73−15

@@ -2,11 +2,14 @@

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE InstanceSigs #-}

4{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE UndecidableInstances #-}

10{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+

10module Reflex.Query.Base

13module Reflex.Query.Base

11 ( QueryT (..)

14 ( QueryT (..)

12 , runQueryT

15 , runQueryT

@@ -19,6 +22,7 @@ module Reflex.Query.Base

19import Control.Applicative (liftA2)

22import Control.Applicative (liftA2)

20import Control.Monad.Exception

23import Control.Monad.Exception

21import Control.Monad.Fix

24import Control.Monad.Fix

25+import Control.Monad.Primitive

22import Control.Monad.Reader

26import Control.Monad.Reader

23import Control.Monad.Ref

27import Control.Monad.Ref

24import Control.Monad.State.Strict

28import Control.Monad.State.Strict

@@ -28,26 +32,34 @@ import qualified Data.Dependent.Map as DMap

28import Data.Foldable

32import Data.Foldable

29import Data.Functor.Compose

33import Data.Functor.Compose

30import Data.Functor.Misc

34import Data.Functor.Misc

35+import Data.IntMap (IntMap)

36+import qualified Data.IntMap as IntMap

31import Data.Map (Map)

37import Data.Map (Map)

32import qualified Data.Map as Map

38import qualified Data.Map as Map

33−import Data.Monoid

39+import Data.Monoid ((<>))

34import qualified Data.Semigroup as S

40import qualified Data.Semigroup as S

35import Data.Some (Some)

41import Data.Some (Some)

36import qualified Data.Some as Some

42import qualified Data.Some as Some

37import Data.These

43import Data.These

39import Reflex.Class

45import Reflex.Class

40−import Reflex.EventWriter

46+import Reflex.Adjustable.Class

47+import Reflex.DynamicWriter.Class

48+import Reflex.EventWriter.Base

49+import Reflex.EventWriter.Class

41import Reflex.Host.Class

50import Reflex.Host.Class

51+import qualified Reflex.Patch.MapWithMove as MapWithMove

42import Reflex.PerformEvent.Class

52import Reflex.PerformEvent.Class

43import Reflex.PostBuild.Class

53import Reflex.PostBuild.Class

44import Reflex.Query.Class

54import Reflex.Query.Class

45import Reflex.Requester.Class

55import Reflex.Requester.Class

46import Reflex.TriggerEvent.Class

56import Reflex.TriggerEvent.Class

47−import qualified Reflex.Patch.MapWithMove as MapWithMove

49newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }

58newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }

50− deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)

59+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)

60+

61+deriving instance MonadHold t m => MonadHold t (QueryT t q m)

62+deriving instance MonadSample t m => MonadSample t (QueryT t q m)

52runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

64runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

53runQueryT (QueryT a) qr = do

65runQueryT (QueryT a) qr = do

@@ -85,6 +97,52 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj

85 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

97 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

86 QueryT $ lift $ tellEvent patches

98 QueryT $ lift $ tellEvent patches

87 return (r0, fmapCheap fst r')

99 return (r0, fmapCheap fst r')

100+

101+ traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v'))

102+ traverseIntMapWithKeyWithAdjust f im0 im' = do

103+ let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')

104+ f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v

105+ (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'

106+ let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0

107+ liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $

108+ IntMap.map (fmap getQueryTLoweredResultValue) p

109+ liftedBs0 :: IntMap [Behavior t q]

110+ liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0

111+ liftedBs' :: Event t (PatchIntMap [Behavior t q])

112+ liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $

113+ IntMap.map (fmap getQueryTLoweredResultWritten) p

114+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

115+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

116+ accumBehaviors :: forall m'. MonadHold t m'

117+ => IntMap [Behavior t q]

118+ -> PatchIntMap [Behavior t q]

119+ -> m' ( Maybe (IntMap [Behavior t q])

120+ , Maybe (AdditivePatch q))

121+ -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.

122+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.

123+ -- bs0 is a Map denoting the behaviors of the current children.

124+ -- pbs is a PatchMap denoting an update to the behaviors of the current children

125+ accumBehaviors bs0 pbs@(PatchIntMap bs') = do

126+ let p k bs = case IntMap.lookup k bs0 of

127+ Nothing -> case bs of

128+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

129+ Nothing -> return mempty

130+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

131+ Just newBs -> sampleBs newBs

132+ Just oldBs -> case bs of

133+ -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

134+ Nothing -> negateG <$> sampleBs oldBs

135+ -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

136+ -- composed with the sampling the child's new state.

137+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

138+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

139+ -- child patches and wrap them in AdditivePatch.

140+ patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'

141+ return (apply pbs bs0, Just patch)

142+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

143+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

144+ return (liftedResult0, liftedResult')

145+

88 traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

146 traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

89 traverseDMapWithKeyWithAdjust f dm0 dm' = do

147 traverseDMapWithKeyWithAdjust f dm0 dm' = do

90 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

148 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

@@ -129,6 +187,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj

129 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

187 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

130 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

188 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

131 return (liftedResult0, liftedResult')

189 return (liftedResult0, liftedResult')

190+

132 traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

191 traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

133 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

192 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

134 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

193 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

@@ -186,6 +245,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj

186instance MonadTrans (QueryT t q) where

245instance MonadTrans (QueryT t q) where

187 lift = QueryT . lift . lift . lift

246 lift = QueryT . lift . lift . lift

188

247

248+instance PrimMonad m => PrimMonad (QueryT t q m) where

249+ type PrimState (QueryT t q m) = PrimState m

250+ primitive = lift . primitive

251+

189instance PostBuild t m => PostBuild t (QueryT t q m) where

252instance PostBuild t m => PostBuild t (QueryT t q m) where

190 getPostBuild = lift getPostBuild

253 getPostBuild = lift getPostBuild

191

254

@@ -215,18 +278,11 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q

215-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

278-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

216instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where

279instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where

217 mempty = pure mempty

280 mempty = pure mempty

218− mappend = liftA2 mappend

281+ mappend = (<>)

219

282

220instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where

283instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where

221 (<>) = liftA2 (S.<>)

284 (<>) = liftA2 (S.<>)

222

285

223−

224−mapQuery :: QueryMorphism q q' -> q -> q'

225−mapQuery = _queryMorphism_mapQuery

226−

227−mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q

228−mapQueryResult = _queryMorphism_mapQueryResult

229−

230-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly

286-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly

231withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')

287withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')

232 => QueryMorphism q q'

288 => QueryMorphism q q'

@@ -252,7 +308,7 @@ dynWithQueryT f q = do

252 return result

308 return result

253 where zipDynIncrementalWith g da ib =

309 where zipDynIncrementalWith g da ib =

254 let eab = align (updated da) (updatedIncremental ib)

310 let eab = align (updated da) (updatedIncremental ib)

255− ec = flip push eab $ \o -> case o of

311+ ec = flip push eab $ \case

256 This a -> do

312 This a -> do

257 aOld <- sample $ current da

313 aOld <- sample $ current da

258 b <- sample $ currentIncremental ib

314 b <- sample $ currentIncremental ib

@@ -273,8 +329,7 @@ instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (Qu

273 askQueryResult = QueryT ask

329 askQueryResult = QueryT ask

274 queryIncremental q = do

330 queryIncremental q = do

275 tellQueryIncremental q

331 tellQueryIncremental q

276− r <- askQueryResult

277− return $ zipDynWith crop (incrementalToDynamic q) r

332+ zipDynWith crop (incrementalToDynamic q) <$> askQueryResult

278

333

279instance Requester t m => Requester t (QueryT t q m) where

334instance Requester t m => Requester t (QueryT t q m) where

280 type Request (QueryT t q m) = Request m

335 type Request (QueryT t q m) = Request m

@@ -284,3 +339,6 @@ instance Requester t m => Requester t (QueryT t q m) where

284

339

285instance EventWriter t w m => EventWriter t w (QueryT t q m) where

340instance EventWriter t w m => EventWriter t w (QueryT t q m) where

286 tellEvent = lift . tellEvent

341 tellEvent = lift . tellEvent

342+

343+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where

344+ tellDyn = lift . tellDyn

src/Reflex/Query/Class.hs+25−3

@@ -15,13 +15,19 @@ module Reflex.Query.Class

15 , MonadQuery (..)

16 , tellQueryDyn

17 , queryDyn

18+ , mapQuery

19+ , mapQueryResult

18 ) where

20 ) where

22+import Control.Category (Category)

23+import qualified Control.Category as Cat

20import Control.Monad.Reader

24import Control.Monad.Reader

21import Data.Bits

25import Data.Bits

22import Data.Data

26import Data.Data

23import Data.Ix

27import Data.Ix

24−import Data.Semigroup

28+import Data.Map.Monoidal (MonoidalMap)

29+import qualified Data.Map.Monoidal as MonoidalMap

30+import Data.Semigroup (Semigroup(..))

25import Foreign.Storable

31import Foreign.Storable

27import Reflex.Class

33import Reflex.Class

@@ -30,6 +36,10 @@ class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where

30 type QueryResult a :: *

36 type QueryResult a :: *

31 crop :: a -> QueryResult a -> QueryResult a

37 crop :: a -> QueryResult a -> QueryResult a

39+instance (Ord k, Query v) => Query (MonoidalMap k v) where

40+ type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)

41+ crop q r = MonoidalMap.intersectionWith (flip crop) r q

42+

33-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type

43-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type

34-- and compatible with the query relationship when acting on the query result

44-- and compatible with the query relationship when acting on the query result

35data QueryMorphism q q' = QueryMorphism

45data QueryMorphism q q' = QueryMorphism

@@ -37,6 +47,19 @@ data QueryMorphism q q' = QueryMorphism

37 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q

47 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q

38 }

48 }

50+instance Category QueryMorphism where

51+ id = QueryMorphism id id

52+ qm . qm' = QueryMorphism

53+ { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'

54+ , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm

55+ }

56+

57+mapQuery :: QueryMorphism q q' -> q -> q'

58+mapQuery = _queryMorphism_mapQuery

59+

60+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q

61+mapQueryResult = _queryMorphism_mapQueryResult

62+

40-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app

63-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app

41newtype SelectedCount = SelectedCount { unSelectedCount :: Int }

64newtype SelectedCount = SelectedCount { unSelectedCount :: Int }

42 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)

65 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)

@@ -73,5 +96,4 @@ tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current

73queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

96queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

74queryDyn q = do

97queryDyn q = do

75 tellQueryDyn q

98 tellQueryDyn q

76− r <- askQueryResult

77− return $ zipDynWith crop q r

99+ zipDynWith crop q <$> askQueryResult

src/Reflex/Requester/Base.hs+120−11

@@ -1,7 +1,6 @@

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

2-- 'Requester'.

3{-# LANGUAGE AllowAmbiguousTypes #-}

4−{-# LANGUAGE BangPatterns #-}

5{-# LANGUAGE CPP #-}

4{-# LANGUAGE CPP #-}

6{-# LANGUAGE EmptyDataDecls #-}

5{-# LANGUAGE EmptyDataDecls #-}

7{-# LANGUAGE ExistentialQuantification #-}

6{-# LANGUAGE ExistentialQuantification #-}

@@ -22,17 +21,24 @@

22module Reflex.Requester.Base

21module Reflex.Requester.Base

23 ( RequesterT (..)

22 ( RequesterT (..)

24 , runRequesterT

23 , runRequesterT

24+ , withRequesterT

25 , runWithReplaceRequesterTWith

26 , traverseIntMapWithKeyWithAdjustRequesterTWith

27 , traverseDMapWithKeyWithAdjustRequesterTWith

28 , RequesterData

29 , RequesterDataKey

30 , traverseRequesterData

31+ , forRequesterData

31 , requesterDataToList

32 , requesterDataToList

32 , singletonRequesterData

33 , singletonRequesterData

34+ , matchResponsesWithRequests

35+ , multiEntry

36+ , unMultiEntry

37+ , requesting'

33 ) where

38 ) where

35import Reflex.Class

40import Reflex.Class

41+import Reflex.Adjustable.Class

36import Reflex.Dynamic

42import Reflex.Dynamic

37import Reflex.Host.Class

43import Reflex.Host.Class

38import Reflex.PerformEvent.Class

44import Reflex.PerformEvent.Class

@@ -43,6 +49,7 @@ import Reflex.TriggerEvent.Class

43import Control.Applicative (liftA2)

49import Control.Applicative (liftA2)

44import Control.Monad.Exception

50import Control.Monad.Exception

45import Control.Monad.Identity

51import Control.Monad.Identity

52+import Control.Monad.Primitive

46import Control.Monad.Reader

53import Control.Monad.Reader

47import Control.Monad.Ref

54import Control.Monad.Ref

48import Control.Monad.State.Strict

55import Control.Monad.State.Strict

@@ -50,7 +57,6 @@ import Data.Bits

50import Data.Coerce

57import Data.Coerce

51import Data.Dependent.Map (DMap, DSum (..))

58import Data.Dependent.Map (DMap, DSum (..))

52import qualified Data.Dependent.Map as DMap

59import qualified Data.Dependent.Map as DMap

53−import qualified Data.Some as Some

54import Data.Functor.Compose

60import Data.Functor.Compose

55import Data.Functor.Misc

61import Data.Functor.Misc

56import Data.IntMap.Strict (IntMap)

62import Data.IntMap.Strict (IntMap)

@@ -58,11 +64,12 @@ import qualified Data.IntMap.Strict as IntMap

58import Data.Map (Map)

64import Data.Map (Map)

59import qualified Data.Map as Map

65import qualified Data.Map as Map

60import Data.Monoid ((<>))

66import Data.Monoid ((<>))

61−import Data.Unique.Tag

67+import Data.Proxy

62import qualified Data.Semigroup as S

68import qualified Data.Semigroup as S

63import Data.Some (Some)

69import Data.Some (Some)

70+import qualified Data.Some as Some

64import Data.Type.Equality

71import Data.Type.Equality

65−import Data.Proxy

72+import Data.Unique.Tag

67import GHC.Exts (Any)

74import GHC.Exts (Any)

68import Unsafe.Coerce

75import Unsafe.Coerce

@@ -110,9 +117,9 @@ singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

110singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

117singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

111

118

112tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

119tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

113−tagMapToList (TagMap m) = fmap f $ IntMap.toList m

120+tagMapToList (TagMap m) = f <$> IntMap.toList m

114 where f :: (Int, Any) -> DSum MyTag f

121 where f :: (Int, Any) -> DSum MyTag f

115− f (k, v) = MyTag k :=> ((unsafeCoerce :: Any -> f a) v)

122+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

116

123

117traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

124traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

118traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

125traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

@@ -130,6 +137,10 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith

130 MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

137 MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

131 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

138 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

132

139

140+-- | 'traverseRequesterData' with its arguments flipped

141+forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

142+forRequesterData r f = traverseRequesterData f r

143+

133data MyTagType :: * -> * where

144data MyTagType :: * -> * where

134 MyTagType_Single :: MyTagType (Single a)

145 MyTagType_Single :: MyTagType (Single a)

135 MyTagType_Multi :: MyTagType Multi

146 MyTagType_Multi :: MyTagType Multi

@@ -239,6 +250,10 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

239deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

250deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

240deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

251deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

241

252

253+instance PrimMonad m => PrimMonad (RequesterT t request response m) where

254+ type PrimState (RequesterT t request response m) = PrimState m

255+ primitive = lift . primitive

256+

242-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

257-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

243instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

258instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

244 mempty = pure mempty

259 mempty = pure mempty

@@ -252,7 +267,6 @@ instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response

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

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

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

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

254-- requests were issued.

269-- requests were issued.

255−

256runRequesterT :: (Reflex t, Monad m)

270runRequesterT :: (Reflex t, Monad m)

257 => RequesterT t request response m a

271 => RequesterT t request response m a

258 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

272 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

@@ -262,6 +276,20 @@ runRequesterT (RequesterT a) responses = do

262 coerceEvent responses

276 coerceEvent responses

263 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

277 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

264

278

279+-- | Map a function over the request and response of a 'RequesterT'

280+withRequesterT

281+ :: (Reflex t, MonadFix m)

282+ => (forall x. req x -> req' x) -- ^ The function to map over the request

283+ -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

284+ -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

285+ -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

286+withRequesterT freq frsp child = do

287+ rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

288+ (a, req) <- lift $ runRequesterT child rsp

289+ rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

290+ fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

291+ return a

292+

265instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

293instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

266 type Request (RequesterT t request response m) = request

294 type Request (RequesterT t request response m) = request

267 type Response (RequesterT t request response m) = response

295 type Response (RequesterT t request response m) = response

@@ -281,7 +309,7 @@ tagRequest req = do

281 return t

309 return t

282

310

283{-# INLINE responseFromTag #-}

311{-# INLINE responseFromTag #-}

284−responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

312+responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

285responseFromTag (MyTagWrap t) = do

313responseFromTag (MyTagWrap t) = do

286 responses :: EventSelectorInt t Any <- RequesterT ask

314 responses :: EventSelectorInt t Any <- RequesterT ask

287 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

315 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

@@ -316,7 +344,7 @@ instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (

316 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

344 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

317 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

345 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

318

346

319−requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

347+requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

320requesting' = responseFromTag . castMyTagWrap <=< tagRequest

348requesting' = responseFromTag . castMyTagWrap <=< tagRequest

321

349

322{-# INLINABLE runWithReplaceRequesterTWith #-}

350{-# INLINABLE runWithReplaceRequesterTWith #-}

@@ -365,7 +393,7 @@ traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIn

365 pack = Entry

393 pack = Entry

366 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

394 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

367 f' k (n, v) = do

395 f' k (n, v) = do

368− (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

396+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

369 return (fmapCheap (IntMap.singleton n) myRequests, result)

397 return (fmapCheap (IntMap.singleton n) myRequests, result)

370 ndm' <- numberOccurrencesFrom 1 dm'

398 ndm' <- numberOccurrencesFrom 1 dm'

371 (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

399 (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

@@ -413,7 +441,7 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

413 pack = Entry

441 pack = Entry

414 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

442 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

415 f' k (Compose (n, v)) = do

443 f' k (Compose (n, v)) = do

416− (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))

444+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))

417 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

445 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

418 ndm' <- numberOccurrencesFrom 1 dm'

446 ndm' <- numberOccurrencesFrom 1 dm'

419 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

447 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

@@ -427,3 +455,84 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

427 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

455 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

428 requests <- holdIncremental requests0 requests'

456 requests <- holdIncremental requests0 requests'

429 return (result0, result')

457 return (result0, result')

458+

459+data Decoder rawResponse response =

460+ forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

461+

462+-- | Matches incoming responses with previously-sent requests

463+-- and uses the provided request "decoder" function to process

464+-- incoming responses.

465+matchResponsesWithRequests

466+ :: forall t rawRequest rawResponse request response m.

467+ ( MonadFix m

468+ , MonadHold t m

469+ , Reflex t

470+ )

471+ => (forall a. request a -> (rawRequest, rawResponse -> response a))

472+ -- ^ Given a request (from 'Requester'), produces the wire format of the

473+ -- request and a function used to process the associated response

474+ -> Event t (RequesterData request)

475+ -- ^ The outgoing requests

476+ -> Event t (Int, rawResponse)

477+ -- ^ The incoming responses, tagged by an identifying key

478+ -> m ( Event t (Map Int rawRequest)

479+ , Event t (RequesterData response)

480+ )

481+ -- ^ A map of outgoing wire-format requests and an event of responses keyed

482+ -- by the 'RequesterData' key of the associated outgoing request

483+matchResponsesWithRequests f send recv = do

484+ rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

485+ waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

486+ holdIncremental mempty $ leftmost

487+ [ fmap (\(_, outstanding, _) -> outstanding) outgoing

488+ , snd <$> incoming

489+ ]

490+ let outgoing = processOutgoing nextId send

491+ incoming = processIncoming waitingFor recv

492+ return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

493+ where

494+ -- Tags each outgoing request with an identifying integer key

495+ -- and returns the next available key, a map of response decoders

496+ -- for requests for which there are outstanding responses, and the

497+ -- raw requests to be sent out.

498+ processOutgoing

499+ :: Behavior t Int

500+ -- The next available key

501+ -> Event t (RequesterData request)

502+ -- The outgoing request

503+ -> Event t ( Int

504+ , PatchMap Int (Decoder rawResponse response)

505+ , Map Int rawRequest )

506+ -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

507+ processOutgoing nextId out = flip pushAlways out $ \dm -> do

508+ oldNextId <- sample nextId

509+ let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

510+ n <- get

511+ put $ succ n

512+ let (rawReq, rspF) = f v

513+ return (n, rawReq, Decoder k rspF)

514+ patchWaitingFor = PatchMap $ Map.fromList $

515+ (\(n, _, dec) -> (n, Just dec)) <$> result

516+ toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

517+ return (newNextId, patchWaitingFor, toSend)

518+ -- Looks up the each incoming raw response in a map of response

519+ -- decoders and returns the decoded response and a patch that can

520+ -- be used to clear the ID of the consumed response out of the queue

521+ -- of expected responses.

522+ processIncoming

523+ :: Incremental t (PatchMap Int (Decoder rawResponse response))

524+ -- A map of outstanding expected responses

525+ -> Event t (Int, rawResponse)

526+ -- A incoming response paired with its identifying key

527+ -> Event t (RequesterData response, PatchMap Int v)

528+ -- The decoded response and a patch that clears the outstanding responses queue

529+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

530+ wf <- sample $ currentIncremental waitingFor

531+ case Map.lookup n wf of

532+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

533+ Just (Decoder k rspF) -> do

534+ let rsp = rspF rawRsp

535+ return $ Just

536+ ( singletonRequesterData k rsp

537+ , PatchMap $ Map.singleton n Nothing

538+ )

src/Reflex/Spider.hs+5−7

@@ -1,22 +1,20 @@

1{-# LANGUAGE CPP #-}

2+-- |

3+-- Module:

4+-- Reflex.Spider

5+-- Description:

2−-- | This module exports all of the user-facing functionality of the 'Spider'

6+-- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine

3−-- 'Reflex' engine

4module Reflex.Spider

7module Reflex.Spider

5 ( Spider

8 ( Spider

6 , SpiderTimeline

9 , SpiderTimeline

7 , Global

10 , Global

8 , SpiderHost

11 , SpiderHost

9 , runSpiderHost

12 , runSpiderHost

10−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

11 , runSpiderHostForTimeline

13 , runSpiderHostForTimeline

12 , newSpiderTimeline

14 , newSpiderTimeline

13 , withSpiderTimeline

15 , withSpiderTimeline

14−#endif

15 -- * Deprecated

16 -- * Deprecated

16 , SpiderEnv

17 , SpiderEnv

17 ) where

18 ) where

19−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

20−import Reflex.Class

21−#endif

22import Reflex.Spider.Internal

20import Reflex.Spider.Internal

src/Reflex/Spider/Internal.hs+247−74

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

9{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MagicHash #-}

13{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

14{-# LANGUAGE MultiWayIf #-}

13{-# LANGUAGE MultiWayIf #-}

15{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE RankNTypes #-}

@@ -21,28 +20,28 @@

21#ifdef USE_REFLEX_OPTIMIZER

20#ifdef USE_REFLEX_OPTIMIZER

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

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

23#endif

22#endif

24−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

25−{-# OPTIONS_GHC -fno-warn-orphans #-}

26−#endif

27-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

23-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

28-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

24-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

29module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

25module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

27+#if MIN_VERSION_base(4,10,0)

31−import Control.Applicative

28+import Control.Applicative (liftA2)

29+#endif

32import Control.Concurrent

30import Control.Concurrent

33import Control.Exception

31import Control.Exception

34−import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

32+import Control.Monad hiding (forM, forM_, mapM, mapM_)

35import Control.Monad.Exception

33import Control.Monad.Exception

36−import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)

34+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

37import Control.Monad.Primitive

35import Control.Monad.Primitive

38−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)

36+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

39import Control.Monad.Ref

37import Control.Monad.Ref

40import Data.Align

38import Data.Align

41import Data.Coerce

39import Data.Coerce

42import Data.Dependent.Map (DMap, DSum (..))

40import Data.Dependent.Map (DMap, DSum (..))

43import qualified Data.Dependent.Map as DMap

41import qualified Data.Dependent.Map as DMap

42+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

43+import qualified Data.FastMutableIntMap as FastMutableIntMap

44import Data.Foldable hiding (concat, elem, sequence_)

45−import Data.Function

46import Data.Functor.Constant

45import Data.Functor.Constant

47import Data.Functor.Misc

46import Data.Functor.Misc

48import Data.Functor.Product

47import Data.Functor.Product

@@ -50,20 +49,16 @@ import Data.GADT.Compare

50import Data.IntMap.Strict (IntMap)

49import Data.IntMap.Strict (IntMap)

51import qualified Data.IntMap.Strict as IntMap

50import qualified Data.IntMap.Strict as IntMap

52import Data.IORef

51import Data.IORef

53−import Data.List hiding (foldl')

52+import Data.Maybe hiding (mapMaybe)

54−import Data.Maybe

55import Data.Monoid ((<>))

53import Data.Monoid ((<>))

56import Data.Proxy

54import Data.Proxy

57import Data.These

55import Data.These

58import Data.Traversable

56import Data.Traversable

59−import Data.Word

57+import Data.Witherable (Filterable, mapMaybe)

60−import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

61−import qualified Data.FastMutableIntMap as FastMutableIntMap

62import GHC.Exts

58import GHC.Exts

63import GHC.IORef (IORef (..))

59import GHC.IORef (IORef (..))

64import GHC.Stack

60import GHC.Stack

65import Reflex.FastWeak

61import Reflex.FastWeak

66−import Reflex.FunctorMaybe

67import System.IO.Unsafe

62import System.IO.Unsafe

68import System.Mem.Weak

63import System.Mem.Weak

69import Unsafe.Coerce

64import Unsafe.Coerce

@@ -78,27 +73,22 @@ import Data.Tree (Forest, Tree (..), drawForest)

79import Data.FastWeakBag (FastWeakBag)

74import Data.FastWeakBag (FastWeakBag)

80import qualified Data.FastWeakBag as FastWeakBag

75import qualified Data.FastWeakBag as FastWeakBag

81−import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

82−import qualified Data.WeakBag as WeakBag

83−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

84import Data.Reflection

76import Data.Reflection

85import Data.Some (Some)

77import Data.Some (Some)

86import qualified Data.Some as Some

78import qualified Data.Some as Some

87import Data.Type.Coercion

79import Data.Type.Coercion

80+import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

81+import qualified Data.WeakBag as WeakBag

88import qualified Reflex.Class

82import qualified Reflex.Class

89import qualified Reflex.Class as R

83import qualified Reflex.Class as R

90import qualified Reflex.Host.Class

84import qualified Reflex.Host.Class

91−#endif

92import Reflex.NotReady.Class

85import Reflex.NotReady.Class

93import Reflex.Patch

86import Reflex.Patch

94import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

87import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

96−-- Note: must come last to silence warnings due to AMP on GHC < 7.10

97−import Prelude hiding (any, concat, mapM, mapM_, sequence)

98−

99#ifdef DEBUG_TRACE_EVENTS

89#ifdef DEBUG_TRACE_EVENTS

100−import System.IO (stderr)

101import qualified Data.ByteString.Char8 as BS8

90import qualified Data.ByteString.Char8 as BS8

91+import System.IO (stderr)

102#endif

92#endif

103

104#ifdef DEBUG_TRACE_EVENTS

94#ifdef DEBUG_TRACE_EVENTS

@@ -245,7 +235,7 @@ subscribeAndRead = unEvent

245-- caching; if the computation function is very cheap, this is (much) more

235-- caching; if the computation function is very cheap, this is (much) more

246-- efficient than 'push'

236-- efficient than 'push'

247{-# INLINE [1] pushCheap #-}

237{-# INLINE [1] pushCheap #-}

248−pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

238+pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

249pushCheap !f e = Event $ \sub -> do

239pushCheap !f e = Event $ \sub -> do

250 (subscription, occ) <- subscribeAndRead e $ sub

240 (subscription, occ) <- subscribeAndRead e $ sub

251 { subscriberPropagate = \a -> do

241 { subscriberPropagate = \a -> do

@@ -389,7 +379,7 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

389eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

379eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

390eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

380eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

391

381

392−eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

382+eventHold :: Hold x p -> Event x p

393eventHold !h = Event $ subscribeHoldEvent h

383eventHold !h = Event $ subscribeHoldEvent h

394

384

395eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

385eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

@@ -646,7 +636,7 @@ walkInvalidHeightParents s0 = do

646#endif

636#endif

647

637

648{-# INLINE subscribeHoldEvent #-}

638{-# INLINE subscribeHoldEvent #-}

649−subscribeHoldEvent :: HasSpiderTimeline x => Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)

639+subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)

650subscribeHoldEvent = subscribeAndRead . holdEvent

640subscribeHoldEvent = subscribeAndRead . holdEvent

651

641

652--------------------------------------------------------------------------------

642--------------------------------------------------------------------------------

@@ -718,13 +708,13 @@ data Dynamic x p = Dynamic

718 , dynamicUpdated :: !(Event x p)

708 , dynamicUpdated :: !(Event x p)

719 }

709 }

720

710

721−dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p

711+dynamicHold :: Hold x p -> Dynamic x p

722dynamicHold !h = Dynamic

712dynamicHold !h = Dynamic

723 { dynamicCurrent = behaviorHold h

713 { dynamicCurrent = behaviorHold h

724 , dynamicUpdated = eventHold h

714 , dynamicUpdated = eventHold h

725 }

715 }

726

716

727−dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

717+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

728dynamicHoldIdentity = dynamicHold

718dynamicHoldIdentity = dynamicHold

729

719

730dynamicConst :: PatchTarget p -> Dynamic x p

720dynamicConst :: PatchTarget p -> Dynamic x p

@@ -760,9 +750,7 @@ data Hold x p

760#endif

750#endif

761 }

751 }

762

752

763−-- | A statically allocated 'SpiderTimeline'; this is the only instance of

753+-- | A statically allocated 'SpiderTimeline'

764−-- 'SpiderTimeline' that can used when using

765−-- -fspecialize-to-spidertimeline-global.

766data Global

754data Global

767

755

768{-# NOINLINE globalSpiderTimelineEnv #-}

756{-# NOINLINE globalSpiderTimelineEnv #-}

@@ -784,17 +772,9 @@ instance Eq (SpiderTimelineEnv x) where

784 _ == _ = True -- Since only one exists of each type

772 _ == _ = True -- Since only one exists of each type

785

773

786instance GEq SpiderTimelineEnv where

774instance GEq SpiderTimelineEnv where

787−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

788− geqToEq _ = id

789− geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b

790− then case unsafeCoerce Refl :: a :~: b of

791− Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

792− else different

793−#else

794 a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

775 a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

795 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

776 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

796 else Nothing

777 else Nothing

797−#endif

798

778

799data EventEnv x

779data EventEnv x

800 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

780 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

@@ -864,11 +844,7 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where

864 delayedRef <- asksEventEnv eventEnvDelayedMerges

844 delayedRef <- asksEventEnv eventEnvDelayedMerges

865 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

845 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

866

846

867−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

868−class x ~ Global => HasSpiderTimeline x where

869−#else

870class HasSpiderTimeline x where

847class HasSpiderTimeline x where

871−#endif

872 -- | Retrieve the current SpiderTimelineEnv

848 -- | Retrieve the current SpiderTimelineEnv

873 spiderTimeline :: SpiderTimelineEnv x

849 spiderTimeline :: SpiderTimelineEnv x

874

850

@@ -1152,14 +1128,18 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

1152newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1128newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1153newInvalidatorPull p = return $! InvalidatorPull p

1129newInvalidatorPull p = return $! InvalidatorPull p

1154

1130

1155−instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1131+instance HasSpiderTimeline x => Filterable (Event x) where

1156− fmapMaybe f = push $ return . f

1132+ mapMaybe f = push $ return . f

1157

1133

1158instance HasSpiderTimeline x => Align (Event x) where

1134instance HasSpiderTimeline x => Align (Event x) where

1159 nil = eventNever

1135 nil = eventNever

1160− align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1136+ align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1161

1137

1138+data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1139+ | BuildDyn !(EventM x (PatchTarget p), Event x p)

1140+ | HoldDyn !(Hold x p)

1141+

1162−newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1142+newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

1163

1143

1164newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1144newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1165newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1145newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

@@ -1180,15 +1160,15 @@ zipDynWith f da db =

1180 return $ Just $ Identity $ f a b

1160 return $ Just $ Identity $ f a b

1181 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1161 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1182

1162

1183−buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1163+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1184buildDynamic readV0 v' = do

1164buildDynamic readV0 v' = do

1185− result <- liftIO $ newIORef $ Left (readV0, v')

1165+ result <- liftIO $ newIORef $ BuildDyn (readV0, v')

1186 let !d = Dyn result

1166 let !d = Dyn result

1187 defer $ SomeDynInit d

1167 defer $ SomeDynInit d

1188 return d

1168 return d

1189

1169

1190unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1170unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1191−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1171+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x

1192 where x = (readV0, v')

1172 where x = (readV0, v')

1193

1173

1194-- ResultM can read behaviors and events

1174-- ResultM can read behaviors and events

@@ -1237,8 +1217,8 @@ coincidence a = eventCoincidence $ Coincidence

1237run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

1217run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

1238run roots after = do

1218run roots after = do

1239 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1219 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1240− t <- SpiderHost ask

1220+ let t = spiderTimeline :: SpiderTimelineEnv x

1241− result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do

1221+ result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

1242 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1222 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1243 occBefore <- liftIO $ do

1223 occBefore <- liftIO $ do

1244 occBefore <- readIORef occRef

1224 occBefore <- readIORef occRef

@@ -1398,14 +1378,21 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)

1398getDynHold d = do

1378getDynHold d = do

1399 mh <- liftIO $ readIORef $ unDyn d

1379 mh <- liftIO $ readIORef $ unDyn d

1400 case mh of

1380 case mh of

1401− Right h -> return h

1381+ HoldDyn h -> return h

1402− Left (readV0, v') -> do

1382+ UnsafeDyn (readV0, v') -> do

1403 holdInits <- getDeferralQueue

1383 holdInits <- getDeferralQueue

1404 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1384 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1385+ hold' v0 v'

1386+ BuildDyn (readV0, v') -> do

1387+ v0 <- liftIO $ runEventM readV0

1388+ hold' v0 v'

1389+ where

1390+ hold' v0 v' = do

1405 h <- hold v0 v'

1391 h <- hold v0 v'

1406− liftIO $ writeIORef (unDyn d) $ Right h

1392+ liftIO $ writeIORef (unDyn d) $ HoldDyn h

1407 return h

1393 return h

1408

1394

1395+

1409-- Always refers to 0

1396-- Always refers to 0

1410{-# NOINLINE zeroRef #-}

1397{-# NOINLINE zeroRef #-}

1411zeroRef :: IORef Height

1398zeroRef :: IORef Height

@@ -2098,7 +2085,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

2098

2085

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

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

2100runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2087runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2101−runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

2088+runFrame a = SpiderHost $ do

2102 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2089 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2103 let go = do

2090 let go = do

2104 result <- a

2091 result <- a

@@ -2139,7 +2126,7 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

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

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

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

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

2141 sub <- newSubscriberSwitch subscribed

2128 sub <- newSubscriberSwitch subscribed

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

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

2143 {-

2130 {-

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

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

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

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

@@ -2254,13 +2241,204 @@ invalidate toReconnectRef wis = do

2254-- Reflex integration

2241-- Reflex integration

2255--------------------------------------------------------------------------------

2242--------------------------------------------------------------------------------

2256

2243

2257−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2244+-- | Designates the default, global Spider timeline

2258−-- When we're specializing, we include this from Reflex.Class instead, because

2245+data SpiderTimeline x

2259−-- it needs access to these types; when we're not, we want them here, so our

2246+type role SpiderTimeline nominal

2260−-- instance isn't an orphan instance.

2247+

2261−#include "SpiderTimeline.include.hs"

2248+-- | The default, global Spider environment

2262−#include "SpiderTimelineHost.include.hs"

2249+type Spider = SpiderTimeline Global

2250+

2251+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where

2252+ {-# INLINABLE sample #-}

2253+ sample (SpiderBehavior b) = readBehaviorUntracked b

2254+

2255+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where

2256+ {-# INLINABLE hold #-}

2257+ hold = holdSpiderEventM

2258+ {-# INLINABLE holdDyn #-}

2259+ holdDyn = holdDynSpiderEventM

2260+ {-# INLINABLE holdIncremental #-}

2261+ holdIncremental = holdIncrementalSpiderEventM

2262+ {-# INLINABLE buildDynamic #-}

2263+ buildDynamic = buildDynamicSpiderEventM

2264+ {-# INLINABLE headE #-}

2265+ headE = R.slowHeadE

2266+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2267+

2268+instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2269+ {-# INLINABLE sample #-}

2270+ sample = coerce . readBehaviorTracked . unSpiderBehavior

2271+

2272+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

2273+ {-# INLINABLE sample #-}

2274+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2275+

2276+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where

2277+ {-# INLINABLE hold #-}

2278+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e

2279+ {-# INLINABLE holdDyn #-}

2280+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

2281+ {-# INLINABLE holdIncremental #-}

2282+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

2283+ {-# INLINABLE buildDynamic #-}

2284+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

2285+ {-# INLINABLE headE #-}

2286+ headE = R.slowHeadE

2287+-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2288+

2289+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2290+ {-# INLINE return #-}

2291+ return = pure

2292+ {-# INLINE (>>=) #-}

2293+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2294+ {-# INLINE (>>) #-}

2295+ (>>) = (*>)

2296+ {-# INLINE fail #-}

2297+ fail _ = error "Dynamic does not support 'fail'"

2298+

2299+{-# INLINABLE newJoinDyn #-}

2300+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2301+newJoinDyn d =

2302+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2303+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

2304+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

2305+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

2306+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

2307+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'

2308+

2309+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

2310+ fmap = mapDynamicSpider

2311+ x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d

2312+

2313+mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b

2314+mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic

2315+{-# INLINE [1] mapDynamicSpider #-}

2316+

2317+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

2318+ pure = SpiderDynamic . dynamicConst

2319+#if MIN_VERSION_base(4,10,0)

2320+ liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)

2263#endif

2321#endif

2322+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

2323+ a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]

2324+ (<*) = flip (*>) -- There are no effects, so order doesn't matter

2325+

2326+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

2327+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2328+

2329+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

2330+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2331+

2332+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

2333+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

2334+

2335+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

2336+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

2337+

2338+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

2339+ {-# INLINABLE hold #-}

2340+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

2341+ {-# INLINABLE holdDyn #-}

2342+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

2343+ {-# INLINABLE holdIncremental #-}

2344+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

2345+ {-# INLINABLE buildDynamic #-}

2346+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2347+ {-# INLINABLE headE #-}

2348+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2349+

2350+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2351+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2352+

2353+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

2354+ {-# INLINABLE hold #-}

2355+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2356+ {-# INLINABLE holdDyn #-}

2357+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2358+ {-# INLINABLE holdIncremental #-}

2359+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

2360+ {-# INLINABLE buildDynamic #-}

2361+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

2362+ {-# INLINABLE headE #-}

2363+ headE = R.slowHeadE

2364+-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2365+

2366+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2367+ {-# INLINABLE sample #-}

2368+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior

2369+

2370+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

2371+ {-# INLINABLE sample #-}

2372+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample

2373+

2374+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

2375+ {-# INLINABLE hold #-}

2376+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e

2377+ {-# INLINABLE holdDyn #-}

2378+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

2379+ {-# INLINABLE holdIncremental #-}

2380+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

2381+ {-# INLINABLE buildDynamic #-}

2382+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

2383+ {-# INLINABLE headE #-}

2384+ headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2385+

2386+--------------------------------------------------------------------------------

2387+-- Deprecated items

2388+--------------------------------------------------------------------------------

2389+

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

2391+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

2392+type SpiderEnv = SpiderTimeline

2393+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2394+ {-# INLINABLE subscribeEvent #-}

2395+ subscribeEvent e = SpiderHostFrame $ do

2396+ --TODO: Unsubscribe eventually (manually and/or with weak ref)

2397+ val <- liftIO $ newIORef Nothing

2398+ subscription <- subscribe (unSpiderEvent e) $ Subscriber

2399+ { subscriberPropagate = \a -> do

2400+ liftIO $ writeIORef val $ Just a

2401+ scheduleClear val

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

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

2404+ }

2405+ return $ SpiderEventHandle

2406+ { spiderEventHandleSubscription = subscription

2407+ , spiderEventHandleValue = val

2408+ }

2409+

2410+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where

2411+ type EventTrigger (SpiderTimeline x) = RootTrigger x

2412+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2413+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x

2414+

2415+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

2416+ {-# NOINLINE readEvent #-}

2417+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do

2418+ result <- readIORef $ spiderEventHandleValue h

2419+ touch h

2420+ return result

2421+

2422+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2423+ newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

2424+ newFanEventWithTrigger f = SpiderHost $ do

2425+ es <- newFanEventWithTriggerIO f

2426+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2427+

2428+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

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

2430+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2431+ es <- newFanEventWithTriggerIO f

2432+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2433+

2434+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

2435+ {-# INLINABLE subscribeEvent #-}

2436+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent

2437+

2438+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

2439+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x

2440+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a

2441+ runHostFrame = runFrame . runSpiderHostFrame

2264

2442

2265unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

2443unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

2266unsafeNewSpiderTimelineEnv = do

2444unsafeNewSpiderTimelineEnv = do

@@ -2277,7 +2455,6 @@ unsafeNewSpiderTimelineEnv = do

2277#endif

2455#endif

2278 }

2456 }

2279

2457

2280−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2281-- | Create a new SpiderTimelineEnv

2458-- | Create a new SpiderTimelineEnv

2282newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2459newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2283newSpiderTimeline = withSpiderTimeline (pure . Some.This)

2460newSpiderTimeline = withSpiderTimeline (pure . Some.This)

@@ -2299,7 +2476,6 @@ withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> I

2299withSpiderTimeline k = do

2476withSpiderTimeline k = do

2300 env <- unsafeNewSpiderTimelineEnv

2477 env <- unsafeNewSpiderTimelineEnv

2301 reify env $ \s -> k $ localSpiderTimeline s env

2478 reify env $ \s -> k $ localSpiderTimeline s env

2302−#endif

2303

2479

2304newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2480newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2305

2481

@@ -2307,7 +2483,6 @@ type ComputeM = EventM

2307

2483

2308newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2484newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2309

2485

2310−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2311instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2486instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2312 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2487 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2313 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2488 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

@@ -2361,7 +2536,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2361 mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2536 mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2362 {-# INLINABLE fanInt #-}

2537 {-# INLINABLE fanInt #-}

2363 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2538 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2364−#endif

2365

2539

2366data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2540data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2367

2541

@@ -2384,7 +2558,7 @@ instance MonadAtomicRef (EventM x) where

2384 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2558 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2385

2559

2386-- | The monad for actions that manipulate a Spider timeline identified by @x@

2560-- | The monad for actions that manipulate a Spider timeline identified by @x@

2387−newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2561+newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2388

2562

2389instance Monad (SpiderHost x) where

2563instance Monad (SpiderHost x) where

2390 {-# INLINABLE (>>=) #-}

2564 {-# INLINABLE (>>=) #-}

@@ -2399,16 +2573,15 @@ instance Monad (SpiderHost x) where

2399-- | Run an action affecting the global Spider timeline; this will be guarded by

2573-- | Run an action affecting the global Spider timeline; this will be guarded by

2400-- a mutex for that timeline

2574-- a mutex for that timeline

2401runSpiderHost :: SpiderHost Global a -> IO a

2575runSpiderHost :: SpiderHost Global a -> IO a

2402−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv

2576+runSpiderHost (SpiderHost a) = a

2403

2577

2404−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2405-- | Run an action affecting a given Spider timeline; this will be guarded by a

2578-- | Run an action affecting a given Spider timeline; this will be guarded by a

2406-- mutex for that timeline

2579-- mutex for that timeline

2407runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2580runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2408−runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2581+runSpiderHostForTimeline (SpiderHost a) _ = a

2409−#endif

2410

2582

2583+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2411−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2584+ deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2412

2585

2413instance Monad (SpiderHostFrame x) where

2586instance Monad (SpiderHostFrame x) where

2414 {-# INLINABLE (>>=) #-}

2587 {-# INLINABLE (>>=) #-}

@@ -2420,7 +2593,7 @@ instance Monad (SpiderHostFrame x) where

2420 {-# INLINABLE fail #-}

2593 {-# INLINABLE fail #-}

2421 fail s = SpiderHostFrame $ fail s

2594 fail s = SpiderHostFrame $ fail s

2422

2595

2423−instance NotReady x (SpiderHostFrame x) where

2596+instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2424 notReadyUntil _ = pure ()

2597 notReadyUntil _ = pure ()

2425 notReady = pure ()

2598 notReady = pure ()

2426

2599

src/Reflex/Spider/SpiderTimeline.include.hsdeleted−155

@@ -1,155 +0,0 @@

1−-- | Designates the default, global Spider timeline

2−data SpiderTimeline x

3−type role SpiderTimeline nominal

4−

5−-- | The default, global Spider environment

6−type Spider = SpiderTimeline Global

7−

8−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where

9− {-# INLINABLE sample #-}

10− sample (SpiderBehavior b) = readBehaviorUntracked b

11−

12−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where

13− {-# INLINABLE hold #-}

14− hold = holdSpiderEventM

15− {-# INLINABLE holdDyn #-}

16− holdDyn = holdDynSpiderEventM

17− {-# INLINABLE holdIncremental #-}

18− holdIncremental = holdIncrementalSpiderEventM

19− {-# INLINABLE buildDynamic #-}

20− buildDynamic = buildDynamicSpiderEventM

21− {-# INLINABLE headE #-}

22− headE = R.slowHeadE

23−-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

24−

25−instance (

26−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

27− x ~ Global

28−#endif

29− ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

30− {-# INLINABLE sample #-}

31− sample = coerce . readBehaviorTracked . unSpiderBehavior

32−

33−instance (

34−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

35− x ~ Global

36−#else

37− HasSpiderTimeline x

38−#endif

39− ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

40− {-# INLINABLE sample #-}

41− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

42−

43−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where

44− {-# INLINABLE hold #-}

45− hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e

46− {-# INLINABLE holdDyn #-}

47− holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

48− {-# INLINABLE holdIncremental #-}

49− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

50− {-# INLINABLE buildDynamic #-}

51− buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

52− {-# INLINABLE headE #-}

53− headE = R.slowHeadE

54−-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

55−

56−instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

57− {-# INLINE return #-}

58− return = pure

59− {-# INLINE (>>=) #-}

60− x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

61− {-# INLINE (>>) #-}

62− (>>) = (*>)

63− {-# INLINE fail #-}

64− fail _ = error "Dynamic does not support 'fail'"

65−

66−{-# INLINABLE newJoinDyn #-}

67−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

68−newJoinDyn d =

69− let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

70− eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

71− eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

72− eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

73− v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

74− in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'

75−

76−instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

77− fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

78− x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d

79−

80−instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

81− pure = SpiderDynamic . dynamicConst

82−#if MIN_VERSION_base(4,10,0)

83− liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)

84−#endif

85− SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

86− a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]

87− (<*) = flip (*>) -- There are no effects, so order doesn't matter

88−

89−holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

90−holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

91−

92−holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

93−holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

94−

95−holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

96−holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

97−

98−buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

99−buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

100−

101−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

102− {-# INLINABLE hold #-}

103− hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

104− {-# INLINABLE holdDyn #-}

105− holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

106− {-# INLINABLE holdIncremental #-}

107− holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

108− {-# INLINABLE buildDynamic #-}

109− buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

110− {-# INLINABLE headE #-}

111− headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

112−

113−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

114− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

115−

116−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

117− {-# INLINABLE hold #-}

118− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

119− {-# INLINABLE holdDyn #-}

120− holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

121− {-# INLINABLE holdIncremental #-}

122− holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

123− {-# INLINABLE buildDynamic #-}

124− buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

125− {-# INLINABLE headE #-}

126− headE = R.slowHeadE

127−-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

128−

129−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

130− {-# INLINABLE sample #-}

131− sample = runFrame . readBehaviorUntracked . unSpiderBehavior

132−

133−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

134− {-# INLINABLE sample #-}

135− sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample

136−

137−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

138− {-# INLINABLE hold #-}

139− hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e

140− {-# INLINABLE holdDyn #-}

141− holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

142− {-# INLINABLE holdIncremental #-}

143− holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

144− {-# INLINABLE buildDynamic #-}

145− buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

146− {-# INLINABLE headE #-}

147− headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

148−

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

150−-- Deprecated items

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

152−

153−-- | 'SpiderEnv' is the old name for 'SpiderTimeline'

154−{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

155−type SpiderEnv = SpiderTimeline

src/Reflex/Spider/SpiderTimelineHost.include.hsdeleted−57

@@ -1,57 +0,0 @@

1−instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2− {-# INLINABLE subscribeEvent #-}

3− subscribeEvent e = SpiderHostFrame $ do

4− --TODO: Unsubscribe eventually (manually and/or with weak ref)

5− val <- liftIO $ newIORef Nothing

6− subscription <- subscribe (unSpiderEvent e) $ Subscriber

7− { subscriberPropagate = \a -> do

8− liftIO $ writeIORef val $ Just a

9− scheduleClear val

10− , subscriberInvalidateHeight = \_ -> return ()

11− , subscriberRecalculateHeight = \_ -> return ()

12− }

13− return $ SpiderEventHandle

14− { spiderEventHandleSubscription = subscription

15− , spiderEventHandleValue = val

16− }

17−

18−instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where

19− type EventTrigger (SpiderTimeline x) = RootTrigger x

20− type EventHandle (SpiderTimeline x) = SpiderEventHandle x

21− type HostFrame (SpiderTimeline x) = SpiderHostFrame x

22−

23−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

24− {-# NOINLINE readEvent #-}

25− readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do

26− result <- readIORef $ spiderEventHandleValue h

27− touch h

28− return result

29−

30−instance (

31−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

32− x ~ Global

33−#endif

34− ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

35− newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

36− newFanEventWithTrigger f = SpiderHost $ lift $ do

37− es <- newFanEventWithTriggerIO f

38− return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

39−

40−instance (

41−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

42− x ~ Global

43−#endif

44− ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

45− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

46− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

47− es <- newFanEventWithTriggerIO f

48− return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

49−

50−instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

51− {-# INLINABLE subscribeEvent #-}

52− subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent

53−

54−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

55− type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x

56− fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a

57− runHostFrame = runFrame . runSpiderHostFrame

src/Reflex/Time.hs+158−14

@@ -1,13 +1,21 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE DeriveTraversable #-}

2{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE RecursiveDo #-}

7{-# LANGUAGE RecursiveDo #-}

5{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE CPP #-}

9+{-# LANGUAGE TupleSections #-}

10+{-# LANGUAGE TypeFamilies #-}

7#ifdef USE_TEMPLATE_HASKELL

11#ifdef USE_TEMPLATE_HASKELL

8{-# LANGUAGE TemplateHaskell #-}

12{-# LANGUAGE TemplateHaskell #-}

9#endif

13#endif

10−{-# LANGUAGE TypeFamilies #-}

14+-- |

15+-- Module:

16+-- Reflex.Time

17+-- Description:

18+-- Clocks, timers, and other time-related functions.

11module Reflex.Time where

19module Reflex.Time where

13import Reflex.Class

21import Reflex.Class

@@ -23,36 +31,50 @@ import Control.Monad

23import Control.Monad.Fix

31import Control.Monad.Fix

24import Control.Monad.IO.Class

32import Control.Monad.IO.Class

25import Data.Align

33import Data.Align

34+import Data.Data (Data)

26import Data.Fixed

35import Data.Fixed

36+import Data.Semigroup (Semigroup(..))

27import Data.Sequence (Seq, (|>))

37import Data.Sequence (Seq, (|>))

28import qualified Data.Sequence as Seq

38import qualified Data.Sequence as Seq

29import Data.These

39import Data.These

30import Data.Time.Clock

40import Data.Time.Clock

31import Data.Typeable

41import Data.Typeable

42+import GHC.Generics (Generic)

32import System.Random

43import System.Random

45+-- | Metadata associated with a timer "tick"

34data TickInfo

46data TickInfo

35 = TickInfo { _tickInfo_lastUTC :: UTCTime

47 = TickInfo { _tickInfo_lastUTC :: UTCTime

36 -- ^ UTC time immediately after the last tick.

48 -- ^ UTC time immediately after the last tick.

37 , _tickInfo_n :: Integer

49 , _tickInfo_n :: Integer

38− -- ^ Number of time periods since t0

50+ -- ^ Number of time periods or ticks since the start of the timer

39 , _tickInfo_alreadyElapsed :: NominalDiffTime

51 , _tickInfo_alreadyElapsed :: NominalDiffTime

40− -- ^ Amount of time already elapsed in the current tick period.

52+ -- ^ Amount of time that has elapsed in the current tick period.

41 }

53 }

42 deriving (Eq, Ord, Show, Typeable)

54 deriving (Eq, Ord, Show, Typeable)

56+-- | Fires an 'Event' once every time provided interval elapses, approximately.

57+-- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick.

44−-- | Special case of tickLossyFrom that uses the post-build event to start the

58+-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread.

45−-- tick thread.

46tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)

59tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)

47tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild

60tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild

49−-- | Send events over time with the given basis time and interval

62+-- | Fires an 'Event' once every time provided interval elapses, approximately.

63+-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread and the time of the post-build as the tick basis time.

64+tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)

65+tickLossyFromPostBuildTime dt = do

66+ postBuild <- getPostBuild

67+ postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild

68+ tickLossyFrom' $ (dt,) <$> postBuildTime

69+

50−-- If the system starts running behind, occurrences will be dropped rather than buffered

70+-- | Fires an 'Event' approximately each time the provided interval elapses. If the system starts running behind, occurrences will be dropped rather than buffered.

51−-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time

71+-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the provided initial time.

52tickLossyFrom

72tickLossyFrom

53 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

73 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

54 => NominalDiffTime

74 => NominalDiffTime

75+ -- ^ The length of a tick interval

55 -> UTCTime

76 -> UTCTime

77+ -- ^ The basis time from which intervals count and with which the initial calculation of elapsed time will be made.

56 -> Event t a

78 -> Event t a

57 -- ^ Event that starts a tick generation thread. Usually you want this to

79 -- ^ Event that starts a tick generation thread. Usually you want this to

58 -- be something like the result of getPostBuild that only fires once. But

80 -- be something like the result of getPostBuild that only fires once. But

@@ -60,12 +82,12 @@ tickLossyFrom

60 -> m (Event t TickInfo)

82 -> m (Event t TickInfo)

61tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e

83tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e

63−-- | Generalization of tickLossyFrom that takes dt and t0 in the event.

85+-- | Generalization of tickLossyFrom that takes the delay and initial time as an 'Event'.

64tickLossyFrom'

86tickLossyFrom'

65 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

87 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

66 => Event t (NominalDiffTime, UTCTime)

88 => Event t (NominalDiffTime, UTCTime)

67 -- ^ Event that starts a tick generation thread. Usually you want this to

89 -- ^ Event that starts a tick generation thread. Usually you want this to

68− -- be something like the result of getPostBuild that only fires once. But

90+ -- be something like the result of 'getPostBuild' that only fires once. But

69 -- there could be uses for starting multiple timer threads.

91 -- there could be uses for starting multiple timer threads.

70 -> m (Event t TickInfo)

92 -> m (Event t TickInfo)

71tickLossyFrom' e = do

93tickLossyFrom' e = do

@@ -76,12 +98,16 @@ tickLossyFrom' e = do

76 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000

98 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000

77 cb (tick, pair)

99 cb (tick, pair)

100

101+-- | Like 'tickLossy', but immediately calculates the first tick and provides a 'Dynamic' that is updated as ticks fire.

79clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)

102clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)

80clockLossy dt t0 = do

103clockLossy dt t0 = do

81 initial <- liftIO $ getCurrentTick dt t0

104 initial <- liftIO $ getCurrentTick dt t0

82 e <- tickLossy dt t0

105 e <- tickLossy dt t0

83 holdDyn initial e

106 holdDyn initial e

107

108+-- | Generates a 'TickInfo', given the specified interval and timestamp. The 'TickInfo' will include the

109+-- current time, the number of ticks that have elapsed since the timestamp, and the amount of time that

110+-- has elapsed since the start time of this tick.

85getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo

111getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo

86getCurrentTick dt t0 = do

112getCurrentTick dt t0 = do

87 t <- getCurrentTime

113 t <- getCurrentTime

@@ -96,7 +122,7 @@ delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do

96 cb a

122 cb a

123

98-- | Send events with Poisson timing with the given basis and rate

124-- | Send events with Poisson timing with the given basis and rate

99−-- Each occurence of the resulting event will contain the index of

125+-- Each occurrence of the resulting event will contain the index of

100-- the current interval, with 0 representing the basis time

126-- the current interval, with 0 representing the basis time

101poissonLossyFrom

127poissonLossyFrom

102 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)

128 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)

@@ -115,7 +141,7 @@ poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate

115

141

116

142

117-- | Send events with Poisson timing with the given basis and rate

143-- | Send events with Poisson timing with the given basis and rate

118−-- Each occurence of the resulting event will contain the index of

144+-- Each occurrence of the resulting event will contain the index of

119-- the current interval, with 0 representing the basis time.

145-- the current interval, with 0 representing the basis time.

120-- Automatically begin sending events when the DOM is built

146-- Automatically begin sending events when the DOM is built

121poissonLossy

147poissonLossy

@@ -222,6 +248,125 @@ batchOccurrences t newValues = do

222 delayed <- delay t toDelay

248 delayed <- delay t toDelay

223 return $ tag buffer delayed

249 return $ tag buffer delayed

224

250

251+-- | Throttle an input event, ensuring that at least a given amount of time passes between occurrences of the output event. If the input event occurs too

252+-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output.

253+-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.

254+throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)

255+throttle t e = do

256+ let f (immediate, buffer) x = case x of -- (Just newState, out)

257+ This a -- If only the input event fires

258+ | immediate -> -- and we're in immediate mode

259+ -- Immediate mode turns off, and the buffer is empty.

260+ -- We fire the output event with the input event value immediately.

261+ (Just (False, Nothing), Just a)

262+ | otherwise -> -- and we're not in immediate mode

263+ -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value.

264+ -- We don't fire the output event.

265+ (Just (False, Just a), Nothing)

266+ That _ -> -- If only the delayed output event fires,

267+ case buffer of

268+ Nothing -> -- and the buffer is empty:

269+ -- Immediate mode turns back on, and the buffer remains empty.

270+ -- We don't fire.

271+ (Just (True, Nothing), Nothing)

272+ Just b -> -- and the buffer is full:

273+ -- Immediate mode remains off, and the buffer is cleared.

274+ -- We fire with the buffered value.

275+ (Just (False, Nothing), Just b)

276+ These a _ -> -- If both the input and delayed output event fire simultaneously:

277+ -- Immediate mode turns off, and the buffer is empty.

278+ -- We fire with the input event's value, as it is the most recent we have seen at this moment.

279+ (Just (False, Nothing), Just a)

280+ rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer.

281+ delayed <- delay t outE

282+ return outE

283+

284+data ThrottleState b

285+ = ThrottleState_Immediate

286+ | ThrottleState_Buffered (ThrottleBuffer b)

287+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)

288+

289+data ThrottleBuffer b

290+ = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning

291+ -- on PatternSynonyms

292+ | ThrottleBuffer_Full b

293+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)

294+

295+instance Semigroup b => Semigroup (ThrottleBuffer b) where

296+ x <> y = case x of

297+ ThrottleBuffer_Empty -> y

298+ ThrottleBuffer_Full b1 -> case y of

299+ ThrottleBuffer_Empty -> x

300+ ThrottleBuffer_Full b2 -> ThrottleBuffer_Full $ b1 <> b2

301+ {-# INLINE (<>) #-}

302+

303+instance Semigroup b => Monoid (ThrottleBuffer b) where

304+ mempty = ThrottleBuffer_Empty

305+ {-# INLINE mempty #-}

306+ mappend = (<>)

307+ {-# INLINE mappend #-}

308+

309+-- | Throttle an input event, ensuring that the output event doesn't occur more often than you are ready for it. If the input event occurs too

310+-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing.

311+-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.

312+-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is

313+-- ready for more input. For example, using @delay 20@ would give a simple time-based throttle.

314+--

315+-- NB: The provided lag function must *actually* delay the event.

316+throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a)

317+-- Invariants:

318+-- * Immediate mode must turn off whenever output is produced.

319+-- * Output must be produced whenever immediate mode turns from on to off.

320+-- * Immediate mode can only go from off to on when the delayed event fires.

321+-- * Every input firing must go into either an immediate output firing or the

322+-- buffer, but not both.

323+-- * An existing full buffer must either stay in the buffer or go to output,

324+-- but not both.

325+throttleBatchWithLag lag e = do

326+ let f state x = case x of -- (Just $ newState, out)

327+ This a -> -- If only the input event fires

328+ case state of

329+ ThrottleState_Immediate -> -- and we're in immediate mode

330+ -- Immediate mode turns off, and the buffer is empty.

331+ -- We fire the output event with the input event value immediately.

332+ (Just $ ThrottleState_Buffered $ ThrottleBuffer_Empty, Just a)

333+ ThrottleState_Buffered b -> -- and we're not in immediate mode

334+ -- Immediate mode remains off, and we accumulate the input value.

335+ -- We don't fire the output event.

336+ (Just $ ThrottleState_Buffered $ b <> ThrottleBuffer_Full a, Nothing)

337+ That _ -> -- If only the delayed output event fires,

338+ case state of

339+ ThrottleState_Immediate -> -- and we're in immediate mode

340+ -- Nothing happens.

341+ (Nothing, Nothing)

342+ ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:

343+ -- Immediate mode turns back on, and the buffer remains empty.

344+ -- We don't fire.

345+ (Just ThrottleState_Immediate, Nothing)

346+ ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:

347+ -- Immediate mode remains off, and the buffer is cleared.

348+ -- We fire with the buffered value.

349+ (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just b)

350+ These a _ -> -- If both the input and delayed output event fire simultaneously:

351+ case state of

352+ ThrottleState_Immediate -> -- and we're in immediate mode

353+ -- Immediate mode turns off, and the buffer is empty.

354+ -- We fire with the input event's value, as it is the most recent we have seen at this moment.

355+ (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)

356+ ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:

357+ -- Immediate mode stays off, and the buffer remains empty.

358+ -- We fire with the input event's value.

359+ (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)

360+ ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:

361+ -- Immediate mode remains off, and the buffer is cleared.

362+ -- We fire with everything including the buffered value.

363+ (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just (b <> a))

364+ rec (_stateDyn, outE) <- mapAccumMaybeDyn f

365+ ThrottleState_Immediate -- We start in immediate mode with an empty buffer.

366+ (align e delayed)

367+ delayed <- lag (void outE)

368+ return outE

369+

225#ifdef USE_TEMPLATE_HASKELL

370#ifdef USE_TEMPLATE_HASKELL

226makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo

371makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo

227#else

372#else

@@ -237,4 +382,3 @@ tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime

237tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3

382tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3

238{-# INLINE tickInfo_alreadyElapsed #-}

383{-# INLINE tickInfo_alreadyElapsed #-}

239#endif

384#endif

240−

src/Reflex/TriggerEvent/Base.hs+3−1

@@ -22,8 +22,10 @@ import Control.Monad.Ref

22import Data.Coerce

23import Data.Dependent.Sum

24import Data.IORef

25+import Data.Monoid ((<>))

25import qualified Data.Semigroup as S

26import qualified Data.Semigroup as S

26import Reflex.Class

27import Reflex.Class

28+import Reflex.Adjustable.Class

27import Reflex.Host.Class

29import Reflex.Host.Class

28import Reflex.PerformEvent.Class

30import Reflex.PerformEvent.Class

29import Reflex.PostBuild.Class

31import Reflex.PostBuild.Class

@@ -134,7 +136,7 @@ instance Adjustable t m => Adjustable t (TriggerEventT t m) where

134-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.

136-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.

135instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where

137instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where

136 mempty = pure mempty

138 mempty = pure mempty

137− mappend = liftA2 mappend

139+ mappend = (<>)

138

140

139instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where

141instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where

140 (<>) = liftA2 (S.<>)

142 (<>) = liftA2 (S.<>)

src/Reflex/Widget/Basic.hs+2

@@ -10,7 +10,9 @@ module Reflex.Widget.Basic where

11import Control.Monad.Fix (MonadFix)

12import Data.Map (Map)

13+

13import Reflex.Class

14import Reflex.Class

15+import Reflex.Adjustable.Class

14import Reflex.Patch.MapWithMove

16import Reflex.Patch.MapWithMove

src/Reflex/Workflow.hs+15−2

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

1−{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE RecursiveDo #-}

1{-# LANGUAGE RecursiveDo #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+-- |

4+-- Module:

5+-- Reflex.Workflow

6+-- Description:

7+-- Provides a convenient way to describe a series of interrelated widgets that

8+-- can send data to, invoke, and replace one another. Useful for modeling user interface

9+-- "workflows."

3module Reflex.Workflow (

10module Reflex.Workflow (

4− -- * Workflows

5 Workflow (..)

11 Workflow (..)

6 , workflow

12 , workflow

7 , workflowView

13 , workflowView

@@ -13,25 +19,32 @@ import Control.Arrow ((***))

13import Control.Monad.Fix (MonadFix)

19import Control.Monad.Fix (MonadFix)

15import Reflex.Class

21import Reflex.Class

22+import Reflex.Adjustable.Class

16import Reflex.Network

23import Reflex.Network

17import Reflex.NotReady.Class

24import Reflex.NotReady.Class

18import Reflex.PostBuild.Class

25import Reflex.PostBuild.Class

27+-- | A widget in a workflow

28+-- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type.

20newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

29newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

31+-- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another).

22workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

32workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

23workflow w0 = do

33workflow w0 = do

24 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

34 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

25 return $ fmap fst eResult

35 return $ fmap fst eResult

37+-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'.

27workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

38workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

28workflowView w0 = do

39workflowView w0 = do

29 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

40 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

30 eReplace <- fmap switch $ hold never $ fmap snd eResult

41 eReplace <- fmap switch $ hold never $ fmap snd eResult

31 return $ fmap fst eResult

42 return $ fmap fst eResult

44+-- | Map a function over a 'Workflow', possibly changing the resturn type.

33mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

45mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

34mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

46mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

48+-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.

36mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

49mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

37mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)

50mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)

stylizenew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+set -euo pipefail

4+for x in **/*.hs ; do stylish-haskell -i "$x" ; done

test/EventWriterT.hs+72−2

@@ -1,12 +1,19 @@

1−{-# LANGUAGE FlexibleContexts, GADTs #-}

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RecursiveDo #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

2module Main where

5module Main where

4import Control.Lens

7import Control.Lens

5import Control.Monad

8import Control.Monad

9+import Control.Monad.Fix

10+import qualified Data.Dependent.Map as DMap

11+import Data.Functor.Misc

12+import qualified Data.Map as M

6import Data.These

13import Data.These

8import Reflex

15import Reflex

9−import Reflex.EventWriter

16+import Reflex.EventWriter.Base

10import Test.Run

17import Test.Run

12main :: IO ()

19main :: IO ()

@@ -23,6 +30,12 @@ main = do

23 , These () ()

30 , These () ()

24 ]

31 ]

25 print os2

32 print os2

33+ os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

34+ print os3

35+ os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

36+ print os4

37+ os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

38+ print os5

26 return ()

39 return ()

28unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])

41unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])

@@ -42,3 +55,60 @@ testSimultaneous pulse = do

42 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

55 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

43 return ()

56 return ()

58+-- | Test that a widget telling and event which fires at the same time it has been replaced

59+-- doesn't count along with the new widget.

60+testMoribundTellEvent

61+ :: forall t m

62+ . ( Reflex t

63+ , Adjustable t m

64+ , MonadHold t m

65+ , MonadFix m

66+ )

67+ => Event t ()

68+ -> EventWriterT t [Int] m ()

69+testMoribundTellEvent pulse = do

70+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

71+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

72+ (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse

73+ return ()

74+

75+-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.

76+testMoribundTellEventDMap

77+ :: forall t m

78+ . ( Reflex t

79+ , Adjustable t m

80+ , MonadHold t m

81+ , MonadFix m

82+ )

83+ => Event t ()

84+ -> EventWriterT t [Int] m ()

85+testMoribundTellEventDMap pulse = do

86+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

87+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

88+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-

89+ traverseDMapWithKeyWithAdjust

90+ (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)

91+ (mapToDMap $ M.singleton () 1)

92+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)

93+ return ()

94+

95+-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's

96+-- during the same frame as other elements are updated.

97+testLiveTellEventDMap

98+ :: forall t m

99+ . ( Reflex t

100+ , Adjustable t m

101+ , MonadHold t m

102+ , MonadFix m

103+ )

104+ => Event t ()

105+ -> EventWriterT t [Int] m ()

106+testLiveTellEventDMap pulse = do

107+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

108+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

109+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-

110+ traverseDMapWithKeyWithAdjust

111+ (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)

112+ (mapToDMap $ M.singleton 1 ())

113+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)

114+ return ()

test/GC.hs+8−3

@@ -1,4 +1,9 @@

1−{-# LANGUAGE OverloadedStrings, FlexibleContexts, GADTs, TypeFamilies, RankNTypes, ScopedTypeVariables #-}

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeFamilies #-}

2module Main where

7module Main where

4import Control.Monad

9import Control.Monad

@@ -17,11 +22,11 @@ import Data.These

17import Data.Functor.Misc

22import Data.Functor.Misc

18import Reflex.Patch

23import Reflex.Patch

20−import qualified Reflex.Spider.Internal as S

21import qualified Reflex.Host.Class as Host

25import qualified Reflex.Host.Class as Host

26+import qualified Reflex.Spider.Internal as S

23−import System.Mem

24import System.Exit

28import System.Exit

29+import System.Mem

26main :: IO ()

31main :: IO ()

27main = do

32main = do

test/QueryT.hs+15−8

@@ -1,18 +1,21 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE RankNTypes #-}

7+{-# LANGUAGE StandaloneDeriving #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

8import Control.Lens

11import Control.Lens

9import Control.Monad.Fix

12import Control.Monad.Fix

10import Data.Align

13import Data.Align

11−import Data.AppendMap (AppendMap)

12import qualified Data.AppendMap as AMap

14import qualified Data.AppendMap as AMap

13import Data.Functor.Misc

15import Data.Functor.Misc

14import Data.Map (Map)

16import Data.Map (Map)

15import qualified Data.Map as Map

17import qualified Data.Map as Map

18+import Data.Map.Monoidal (MonoidalMap)

16import Data.Semigroup

19import Data.Semigroup

17import Data.These

20import Data.These

@@ -27,14 +30,18 @@ instance Query MyQuery where

27 type QueryResult MyQuery = ()

30 type QueryResult MyQuery = ()

28 crop _ _ = ()

31 crop _ _ = ()

30−instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where

33+instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where

31 type QueryResult (Selector k a) = Selector k (QueryResult a)

34 type QueryResult (Selector k a) = Selector k (QueryResult a)

32 crop q r = undefined

35 crop q r = undefined

34−newtype Selector k a = Selector { unSelector :: AppendMap k a }

37+newtype Selector k a = Selector { unSelector :: MonoidalMap k a }

35 deriving (Show, Read, Eq, Ord, Functor)

38 deriving (Show, Read, Eq, Ord, Functor)

40+#if !(MIN_VERSION_monoidal_containers(0,4,1))

41+deriving instance Ord k => Align (MonoidalMap k)

42+#endif

43+

37−instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where

44+instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where

38 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b

45 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b

39 where

46 where

40 f = alignWith $ \case

47 f = alignWith $ \case

@@ -44,14 +51,14 @@ instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where

44 let z = x `mappend` y

51 let z = x `mappend` y

45 in if z == mempty then Nothing else Just z

52 in if z == mempty then Nothing else Just z

47−instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where

54+instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where

48 mempty = Selector AMap.empty

55 mempty = Selector AMap.empty

49 mappend = (<>)

56 mappend = (<>)

51−instance (Eq a, Ord k, Group a) => Group (Selector k a) where

58+instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where

52 negateG = fmap negateG

59 negateG = fmap negateG

54−instance (Eq a, Ord k, Group a) => Additive (Selector k a)

61+instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a)

56main :: IO ()

63main :: IO ()

57main = do

64main = do

test/Reflex/Bench/Focused.hs+1−1

@@ -184,7 +184,7 @@ switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges

184

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

186holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))

187−holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes

187+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes

188

189 where

190 modify k Nothing items = Map.delete k items

test/Reflex/Plan/Pure.hs+4−4

@@ -55,15 +55,15 @@ instance TestPlan (Pure Int) PurePlan where

55runPure :: PurePlan a -> (a, IntSet)

56runPure (PurePlan p) = runStateT p mempty $ 0

58−relavantTimes :: IntSet -> IntSet

58+relevantTimes :: IntSet -> IntSet

59−relavantTimes occs = IntSet.fromList [0..l + 1]

59+relevantTimes occs = IntSet.fromList [0..l + 1]

60 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

62testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

63−testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)

63+testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs)

65testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

66−testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)

66+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs)

test/Reflex/Plan/Reflex.hs+2−2

@@ -74,13 +74,13 @@ deriving instance ReflexHost t => MonadFix (Plan t)

76instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where

77− plan occurances = Plan $ do

77+ plan occurrences = Plan $ do

78 (e, ref) <- newEventWithTriggerRef

79 modify (IntMap.unionWith mappend (firings ref))

80 return e

82 where

83− firings ref = IntMap.fromList (makeFiring ref <$> occurances)

83+ firings ref = IntMap.fromList (makeFiring ref <$> occurrences)

84 makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])

test/Reflex/Test/CrossImpl.hs+20−21

@@ -12,7 +12,6 @@

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

15−module Reflex.Test.CrossImpl (test) where

17import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)

16import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)

@@ -20,21 +19,18 @@ import Control.Monad.Ref

20import Reflex.Class

19import Reflex.Class

21import Reflex.Dynamic

20import Reflex.Dynamic

22import Reflex.Host.Class

21import Reflex.Host.Class

23−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

24import qualified Reflex.Pure as P

22import qualified Reflex.Pure as P

25import qualified Reflex.Spider.Internal as S

23import qualified Reflex.Spider.Internal as S

27import Control.Arrow (second, (&&&))

25import Control.Arrow (second, (&&&))

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

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

29import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

27import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

30−import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

31−import Data.Dependent.Map (DMap, DSum (..))

28+import Data.Dependent.Map (DSum (..))

32−import qualified Data.Dependent.Map as DMap

33import Data.Foldable

29import Data.Foldable

34−import Data.Functor.Misc

35import Data.Map.Strict (Map)

30import Data.Map.Strict (Map)

36import qualified Data.Map.Strict as Map

31import qualified Data.Map.Strict as Map

37import qualified Data.Set as Set

32import qualified Data.Set as Set

33+import Data.Monoid

38import Data.Traversable

34import Data.Traversable

39import System.Exit

35import System.Exit

40import System.Mem

36import System.Mem

@@ -155,35 +151,35 @@ testCases =

155 let e' = leftmost [e, e]

151 let e' = leftmost [e, e]

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

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

157 return (b, e'')

153 return (b, e'')

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

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

159 let e' = fmap (const e) e

155 let e' = fmap (const e) e

160− e'' <- switchPromptly never e'

156+ e'' <- switchHoldPromptly never e'

161 return (b, e'')

157 return (b, e'')

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

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

163 let e' = fmap (const e) e

159 let e' = fmap (const e) e

164− e'' <- switchPromptly never $ leftmost [e', e']

160+ e'' <- switchHoldPromptly never $ leftmost [e', e']

165 return (b, e'')

161 return (b, e'')

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

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

167 let e' = leftmost [e, e]

163 let e' = leftmost [e, e]

168− e'' <- switchPromptly never (fmap (const e) e')

164+ e'' <- switchHoldPromptly never (fmap (const e) e')

169 return (b, e'')

165 return (b, e'')

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

166+ , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do

171 let e' = leftmost [e, e]

167 let e' = leftmost [e, e]

172− e'' <- switchPromptly never (fmap (const e') e)

168+ e'' <- switchHoldPromptly never (fmap (const e') e)

173 return (b, e'')

169 return (b, e'')

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

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

175 let e' = leftmost [e, e]

171 let e' = leftmost [e, e]

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

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

177 return (b, e'')

173 return (b, e'')

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

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

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

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

180 Just <$> headE e

176 Just <$> headE e

181− e'' <- switchPromptly never e'

177+ e'' <- switchHoldPromptly never e'

182 return (b, e'')

178 return (b, e'')

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

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

184 let e' = flip pushAlways e $ \_ -> do

180 let e' = flip pushAlways e $ \_ -> do

185− switchPromptly e never

181+ switchHoldPromptly e never

186− e'' <- switchPromptly never e'

182+ e'' <- switchHoldPromptly never e'

187 return (b, e'')

183 return (b, e'')

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

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

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

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

@@ -233,6 +229,9 @@ testCases =

233 rec result <- holdUniqDyn d

229 rec result <- holdUniqDyn d

234 d <- holdDyn (0 :: Int) e

230 d <- holdDyn (0 :: Int) e

235 return (current result, updated result)

231 return (current result, updated result)

232+

233+

234+

236 {-

235 {-

237 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

236 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

238 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

237 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

@@ -248,8 +247,8 @@ splitRecombineEvent e =

248 in leftmost [ea, eb]

247 in leftmost [ea, eb]

249

248

250

249

251−test :: IO ()

250+main :: IO ()

252−test = do

251+main = do

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

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

254 putStrLn $ "Test: " <> name

253 putStrLn $ "Test: " <> name

255 testAgreement builder inputs

254 testAgreement builder inputs

test/Reflex/Test/Micro.hs+77−16

@@ -3,6 +3,7 @@

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RecursiveDo #-}

9{-# LANGUAGE RecursiveDo #-}

@@ -23,6 +24,24 @@ import Data.Monoid

24import Prelude

25import Prelude

27+pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)

28+pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))

29+

30+foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)

31+foldedDyn f d = fmap join $ flip buildDynamic never $ do

32+ a <- sample (current d)

33+ foldDyn f a (updated d)

34+

35+scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])

36+scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure

37+

38+scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])

39+scanInnerDyns d = do

40+ scans <- scannedDyn d

41+ return (join (fmap distributeListOverDynPure scans))

42+

43+

44+

26{-# ANN testCases "HLint: ignore Functor law" #-}

45{-# ANN testCases "HLint: ignore Functor law" #-}

27testCases :: [(String, TestCase)]

46testCases :: [(String, TestCase)]

28testCases =

47testCases =

@@ -128,36 +147,36 @@ testCases =

128 return $ coincidence $ flip pushAlways e $ const $ do

147 return $ coincidence $ flip pushAlways e $ const $ do

129 switch <$> hold ("x" <$ e) (e <$ e)

148 switch <$> hold ("x" <$ e) (e <$ e)

130

149

131− , testE "switchPromptly-1" $ do

150+ , testE "switchHoldPromptly-1" $ do

132 e <- events1

151 e <- events1

133 let e' = e <$ e

152 let e' = e <$ e

134− switchPromptly never $ e <$ e'

153+ switchHoldPromptly never $ e <$ e'

135

154

136− , testE "switchPromptly-2" $ do

155+ , testE "switchHoldPromptly-2" $ do

137 e <- events1

156 e <- events1

138− switchPromptly never $ deep (e <$ e)

157+ switchHoldPromptly never $ deep (e <$ e)

139

158

140− , testE "switchPromptly-3" $ do

159+ , testE "switchHoldPromptly-3" $ do

141 e <- events1

160 e <- events1

142− switchPromptly never $ (e <$ deep e)

161+ switchHoldPromptly never $ (e <$ deep e)

143

162

144− , testE "switchPromptly-4" $ do

163+ , testE "switchHoldPromptly-4" $ do

145 e <- events1

164 e <- events1

146− switchPromptly never $ (deep e <$ e)

165+ switchHoldPromptly never $ (deep e <$ e)

147

166

148 , testE "switch-5" $ do

167 , testE "switch-5" $ do

149 e <- events1

168 e <- events1

150 switch <$> hold never (deep e <$ e)

169 switch <$> hold never (deep e <$ e)

151

170

152− , testE "switchPromptly-5" $ do

171+ , testE "switchHoldPromptly-5" $ do

153 e <- events1

172 e <- events1

154− switchPromptly never $ flip push e $

173+ switchHoldPromptly never $ flip push e $

155 const (Just <$> headE e)

174 const (Just <$> headE e)

156

175

157− , testE "switchPromptly-6" $ do

176+ , testE "switchHoldPromptly-6" $ do

158 e <- events1

177 e <- events1

159− switchPromptly never $ flip pushAlways e $

178+ switchHoldPromptly never $ flip pushAlways e $

160− const (switchPromptly e never)

179+ const (switchHoldPromptly e never)

161

180

162 , testE "coincidence-1" $ do

181 , testE "coincidence-1" $ do

163 e <- events1

182 e <- events1

@@ -201,6 +220,14 @@ testCases =

201 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo

220 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo

202 return $ pull $ sample =<< sample bb

221 return $ pull $ sample =<< sample bb

203

222

223+

224+ , testB "foldDynWhileFiring" $ do

225+ e <- events1

226+ d <- foldDyn (:) [] $

227+ pushAlways (\a -> foldDyn (:) [a] e) e

228+

229+ return $ current (join (fmap distributeListOverDynPure d))

230+

204 , testE "joinDyn" $ do

231 , testE "joinDyn" $ do

205 e <- events1

232 e <- events1

206 bb <- hold "b" e

233 bb <- hold "b" e

@@ -223,6 +250,38 @@ testCases =

223 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2

250 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2

224

251

225 return $ current $ zipDynWith (<>) d1 d2

252 return $ current $ zipDynWith (<>) d1 d2

253+

254+ , testB "buildDynamicStrictness" $ do

255+ rec

256+ d'' <- pushDyn return d'

257+ d' <- pushDyn return d

258+ d <- holdDyn "0" =<< events1

259+

260+ _ <- sample (current d'')

261+ return (current d'')

262+

263+ , testB "factorDyn" $ do

264+ d <- holdDyn (Left "a") =<< eithers

265+

266+ eithers' <- eitherDyn d

267+ let unFactor = either id id

268+ return $ current (join (fmap unFactor eithers'))

269+

270+ , testB "pushDynDeep" $ do

271+ _ <- events1

272+ _ <- events2

273+

274+ d1 <- holdDyn "d1" =<< events1

275+ d2 <- holdDyn "d2" =<< events2

276+

277+ d <- flip pushDyn d1 $ \a ->

278+ flip pushDyn d2 $ \b ->

279+ flip pushDyn d1 $ \c ->

280+ return (a <> b <> c)

281+

282+ d' <- pushDyn scanInnerDyns d >>= scanInnerDyns

283+ return $ current d'

284+

226 , testE "fan-1" $ do

285 , testE "fan-1" $ do

227 e <- fmap toMap <$> events1

286 e <- fmap toMap <$> events1

228 let es = select (fanMap e) . Const2 <$> values

287 let es = select (fanMap e) . Const2 <$> values

@@ -264,14 +323,18 @@ testCases =

264 return $ void e

323 return $ void e

265 lazyHold

324 lazyHold

266

325

326+

267 ] where

327 ] where

268

328

269 events1, events2, events3 :: TestPlan t m => m (Event t String)

329 events1, events2, events3 :: TestPlan t m => m (Event t String)

270 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]

330 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]

271 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]

331 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]

272−

273 events3 = liftA2 mappend events1 events2

332 events3 = liftA2 mappend events1 events2

274

333

334+ eithers :: TestPlan t m => m (Event t (Either String String))

335+ eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]

336+

337+

275 values = "abcde"

338 values = "abcde"

276 toMap str = Map.fromList $ map (\c -> (c, c)) str

339 toMap str = Map.fromList $ map (\c -> (c, c)) str

277

340

@@ -281,5 +344,3 @@ testCases =

281

344

282 deep e = leftmost [e, e]

345 deep e = leftmost [e, e]

283 leftmost2 e1 e2 = leftmost [e1, e2]

346 leftmost2 e1 e2 = leftmost [e1, e2]

284−

285−

test/Reflex/TestPlan.hs+2−2

@@ -26,8 +26,8 @@ import Reflex.Class

26import Prelude

28class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where

29− -- | Speicify a plan of an input Event firing

29+ -- | Specify a plan of an input Event firing

30− -- Occurances must be in the future (i.e. Time > 0)

30+ -- Occurrences must be in the future (i.e. Time > 0)

31 -- Initial specification is

33 plan :: [(Word, a)] -> m (Event t a)

test/RequesterT.hs+6−4

@@ -1,4 +1,7 @@

1−{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-}

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

2module Main where

5module Main where

4import Control.Lens

7import Control.Lens

@@ -48,9 +51,8 @@ testOrdering :: ( Response m ~ Identity

48 , Adjustable t m)

51 , Adjustable t m)

49 => Event t ()

52 => Event t ()

50 -> m ()

53 -> m ()

51−testOrdering pulse = do

54+testOrdering pulse = forM_ [10,9..1] $ \i ->

52− forM_ [10,9..1] $ \i -> requestingIdentity (RequestInt i <$ pulse)

55+ requestingIdentity (RequestInt i <$ pulse)

53− return ()

55testSimultaneous :: ( Response m ~ Identity

57testSimultaneous :: ( Response m ~ Identity

56 , Request m ~ RequestInt

58 , Request m ~ RequestInt

test/Test/Run.hs+8

@@ -64,3 +64,11 @@ runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

64runApp' app input = do

65 let app' = fmap (AppOut (pure ())) . app

66 map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input)

67+

68+runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

69+ => (Event t eIn -> PerformEventT t m (Behavior t bOut))

70+ -> [Maybe eIn]

71+ -> IO [[bOut]]

72+runAppB app input = do

73+ let app' = fmap (flip AppOut never) . app

74+ map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input)

test/hlint.hs+3−2

@@ -4,8 +4,8 @@ import Control.Monad

4import Language.Haskell.HLint3 (hlint)

5import System.Directory

6import System.Exit (exitFailure, exitSuccess)

7−import System.FilePath.Find

8import System.FilePath

7import System.FilePath

8+import System.FilePath.Find

10main :: IO ()

11main = do

@@ -20,6 +20,7 @@ main = do

20 , "--ignore=Use >=>"

21 , "--ignore=Use ."

22 , "--ignore=Use unless"

23+ , "--ignore=Reduce duplication"

23 , "--cpp-define=USE_TEMPLATE_HASKELL"

24 , "--cpp-define=USE_TEMPLATE_HASKELL"

24 ]

25 ]

25 recurseInto = and <$> sequence

26 recurseInto = and <$> sequence

@@ -31,7 +32,7 @@ main = do

31 , let notElem' = liftOp notElem

32 , let notElem' = liftOp notElem

32 in filePath `notElem'` filePathExceptions pwd

33 in filePath `notElem'` filePathExceptions pwd

33 ]

34 ]

34− files <- find recurseInto matchFile pwd

35+ files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

35 ideas <- fmap concat $ forM files $ \f -> do

36 ideas <- fmap concat $ forM files $ \f -> do

36 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

37 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

37 runHlint f

38 runHlint f

test/rootCleanup.hs+3−3

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

1−import Control.Monad

2import Control.Concurrent

1import Control.Concurrent

2+import Control.Monad

3+import Data.IORef

3import Reflex

4import Reflex

4import Reflex.Host.Class

5import Reflex.Host.Class

5−import System.Mem

6−import Data.IORef

7import System.Exit

6import System.Exit

7+import System.Mem

9main :: IO ()

10main = do

test/semantics.hs−2

@@ -50,5 +50,3 @@ main = do

50 ]

52 makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests

53−

54−