0b3ca54 · reflex · git.iko.soy

git.iko.soy/reflex

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

* origin/develop: (147 commits) Add Num instance for Dynamic Bump to version 0.6 Re-export mapMaybe from Filterable Update Collection.hs Remove some more long-deprecated functions Organize exports under correct headings Fix warnings Deprecate FunctorMaybe in favor of Filterable Unorphan MonoidalMap Group and Additive instances Remove some long-deprecated functions Add some docs Add matchResponsesWithRequests Add withRequesterT Bump version in default.nix Bump version to 0.5.0.1 Relax bounds on 'these', add explicit import to avoid clash Update the types of merge and fan Add missing haddock hyperlinks Conditionally import 'Semigroup' Add missing imports ...

commit0b3ca54ed156ea9018eb8ef4b5e14b7669c3e4f3 authorAli Abrar <aliabrar@gmail.com> dateSun 17 Mar 2019, 23:47 (8 years ago) parentc2c3f13 6a38fdd

75 files changed+3426−2466

compare with develop

unifiedsplit

.stylish-haskell.yaml+2−3 .travis.yml−16 Quickref.md+36−11 bench-cbits/checkCapability.c+11−12 bench/Main.hs+7−6 bench/RunAll.hs+1−1 default.nix+9−4 hydra.json+29 jobsets.nix+70 reflex-platform.nix+8 reflex.cabal+105−62 release.nix+9 src/Data/AppendMap.hs+36−373 src/Data/FastMutableIntMap.hs+3−7 src/Data/FastWeakBag.hs+6−7 src/Data/Functor/Misc.hs+2−121 src/Data/Map/Misc.hs+27−11 src/Data/WeakBag.hs+5−8 src/Reflex.hs+8−2 src/Reflex/Adjustable/Class.hs+58−111 src/Reflex/BehaviorWriter/Base.hs+202 src/Reflex/BehaviorWriter/Class.hs+26 src/Reflex/Class.hs+547−326 src/Reflex/Collection.hs+157−60 src/Reflex/Dynamic.hs+60−208 src/Reflex/Dynamic/TH.hs+1−26 src/Reflex/DynamicWriter.hs+4−221 src/Reflex/DynamicWriter/Base.hs+237 src/Reflex/DynamicWriter/Class.hs+24 src/Reflex/EventWriter.hs+4−279 src/Reflex/EventWriter/Base.hs+306 src/Reflex/EventWriter/Class.hs+27 src/Reflex/FastWeak.hs+63−6 src/Reflex/FunctorMaybe.hs+30−18 src/Reflex/Host/Class.hs+6−25 src/Reflex/Network.hs+14−9 src/Reflex/NotReady/Class.hs+17−6 src/Reflex/Optimizer.hs+13−4 src/Reflex/Patch.hs+20−8 src/Reflex/Patch/Class.hs+12 src/Reflex/Patch/DMap.hs+23−9 src/Reflex/Patch/DMapWithMove.hs+136−53 src/Reflex/Patch/IntMap.hs+20−3 src/Reflex/Patch/Map.hs+2−3 src/Reflex/Patch/MapWithMove.hs+134−20 src/Reflex/PerformEvent/Base.hs+4−3 src/Reflex/PostBuild/Base.hs+2−1 src/Reflex/Profiled.hs+19−5 src/Reflex/Pure.hs+11−9 src/Reflex/Query/Base.hs+73−15 src/Reflex/Query/Class.hs+25−3 src/Reflex/Requester/Base.hs+120−11 src/Reflex/Spider.hs+5−7 src/Reflex/Spider/Internal.hs+247−74 src/Reflex/Spider/SpiderTimeline.include.hs−155 src/Reflex/Spider/SpiderTimelineHost.include.hs−57 src/Reflex/Time.hs+158−14 src/Reflex/TriggerEvent/Base.hs+3−1 src/Reflex/Widget/Basic.hs+2 src/Reflex/Workflow.hs+15−2 stylize+4 test/EventWriterT.hs+72−2 test/GC.hs+8−3 test/QueryT.hs+15−8 test/Reflex/Bench/Focused.hs+1−1 test/Reflex/Plan/Pure.hs+4−4 test/Reflex/Plan/Reflex.hs+2−2 test/Reflex/Test/CrossImpl.hs+20−21 test/Reflex/Test/Micro.hs+77−16 test/Reflex/TestPlan.hs+2−2 test/RequesterT.hs+6−4 test/Test/Run.hs+8 test/hlint.hs+3−2 test/rootCleanup.hs+3−3 test/semantics.hs−2

.stylish-haskell.yaml+2−3

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

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

150150#

151151# No language extensions are enabled by default.

152−# language_extensions:

153− # - TemplateHaskell

154− # - QuasiQuotes

152+language_extensions:

153+ - TemplateHaskell

.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

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

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

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

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

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

3434

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

3636[ ] 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

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

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

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

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

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

5151

5252-- Combine multiple Events

5353[ ] <> :: 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

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

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

5959[ ] 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)

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

6262

6363-- Efficient one-to-many fanout

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

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

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

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

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

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

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

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

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

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

6969

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

7171[ ] 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

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

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

100100

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+

101105-- Behavior to Behavior by sampling current values

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

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

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

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

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

137141

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+

138146-- Efficient one-to-many fanout

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

140148[ ] 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

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

160168

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

163171

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

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

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

182190

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

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

186194```

187195

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

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

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

248256

249257-- 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 =>

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

252260```

253261

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

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

285293```

286294

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_ {

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

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

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

45− rtsBool wakeup;

45+ HsBool wakeup;

4646#endif

4747

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

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

6262 // The current top-of-stack InCall

6363 struct InCall_ *incall;

6464

65− nat n_spare_incalls;

65+ uint32_t n_spare_incalls;

6666 struct InCall_ *spare_incalls;

6767

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

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

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

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

7070

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

72− rtsBool running_finalizers;

72+ HsBool running_finalizers;

7373

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

7575 // on spare_workers.

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

8888 StgFunTable f;

8989 StgRegTable r;

9090

91− nat no; // capability number.

91+ uint32_t no; // capability number.

9292

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

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

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

9898

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

100100 // catching unsafe call-ins.

101− rtsBool in_haskell;

101+ HsBool in_haskell;

102102

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

104− nat idle;

104+ uint32_t idle;

105105

106− rtsBool disabled;

106+ HsBool disabled;

107107

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

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

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

159159#if defined(THREADED_RTS)

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

161161 Task *spare_workers;

162− nat n_spare_workers; // count of above

162+ uint32_t n_spare_workers; // count of above

163163

164164 // This lock protects:

165165 // running_task

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

192192

193193 // Per-capability STM-related data

194194 StgTVarWatchQueue *free_tvar_watch_queues;

195− StgInvariantCheckQueue *free_invariant_check_queues;

196195 StgTRecChunk *free_trec_chunks;

197196 StgTRecHeader *free_trec_headers;

198− nat transaction_tokens;

197+ uint32_t transaction_tokens;

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

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

201200 // 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

2020import Data.Dependent.Sum

2121import Data.Functor.Misc

2222import Data.IORef

23+import Data.Maybe (fromJust)

2324import Reflex

2425import Reflex.Host.Class

2526

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

7071 , withSetupWHNF "fireEventsOnly"

7172 (newEventWithTriggerRef >>= subscribePair)

7273 (\(_, trigger) -> do

73− Just key <- liftIO $ readIORef trigger

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

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

7576 , withSetupWHNF "fireEventsAndRead(head/merge1)"

7677 (setupMerge 1 >>= subscribePair)

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

8485 , withSetupWHNF "fireEventsOnly(head/merge100)"

8586 (setupMerge 100 >>= subscribePair)

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

87− Just key <- liftIO $ readIORef t

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

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

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

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

9192 ]

9293

9394setupMerge :: Int

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

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

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

9697 )

9798setupMerge num = do

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

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

100101 pure (merge m, triggers)

101102

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)

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

104105

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

106107 -> SpiderHost Global (Maybe b)

107108fireAndRead trigger val subd = do

108− Just key <- liftIO $ readIORef trigger

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

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

bench/RunAll.hs+1−1

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

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

137137

138138spawnBenchmark :: String -> Benchmark

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

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

140140 self <- getExecutablePath

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

142142

default.nix+9−4

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

55, semigroupoids, semigroups, split, stdenv, stm, syb

66, template-haskell, these, time, transformers

77, 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

911, useTemplateHaskell ? true

1012}:

1113

1214mkDerivation {

1315 pname = "reflex";

14− version = "0.5.0";

16+ version = "0.5.0.1";

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

1618 libraryHaskellDepends = [

1719 base bifunctors containers dependent-map dependent-sum

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

2123 transformers-compat prim-uniq

2224 base bifunctors containers deepseq dependent-map dependent-sum

2325 mtl ref-tf split transformers data-default

24− random time unbounded-delays generics-sop

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

26+ random time unbounded-delays monoidal-containers witherable

27+ generics-sop

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

29+ ghcjs-base

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

2631 haskell-src-exts haskell-src-meta

2732 ]);

2833 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 @@

11Name: reflex

2−Version: 0.5

2+Version: 0.6

33Synopsis: Higher-order Functional Reactive Programming

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

55License: BSD3

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

1010Category: FRP

1111Build-type: Simple

1212Cabal-version: >=1.9.2

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

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

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

15−

16−flag specialize-to-spidertimeline-global

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

18− default: False

19− manual: True

15+extra-source-files:

16+ README.md

17+ Quickref.md

2018

2119flag use-reflex-optimizer

2220 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

2826 default: True

2927 manual: True

3028

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−

3629flag debug-trace-events

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

3831 default: False

3932 manual: True

4033

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−

4634flag fast-weak

4735 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

4836 default: False

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

5240 hs-source-dirs: src

5341 build-depends:

5442 MemoTrie == 0.6.*,

55− base >= 4.7 && < 4.11,

56− bifunctors >= 5.2 && < 5.5,

43+ base >= 4.9 && < 4.13,

44+ bifunctors >= 5.2 && < 5.6,

5745 comonad,

58− containers == 0.5.*,

46+ containers >= 0.5 && < 0.7,

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

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

6149 exception-transformers == 0.4.*,

6250 generics-sop >= 0.2.4.0,

6351 lens >= 4.7 && < 5,

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

53+ monoidal-containers == 0.4.*,

6554 mtl >= 2.1 && < 2.3,

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

6756 primitive >= 0.5 && < 0.7,

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

7059 reflection == 2.1.*,

7160 semigroupoids >= 4.0 && < 6,

7261 semigroups >= 0.16 && < 0.19,

73− stm == 2.4.*,

62+ stm >= 2.4 && < 2.6,

7463 syb >= 0.5 && < 0.8,

75− these >= 0.4 && < 0.8,

64+ these >= 0.4 && < 0.7.7,

7665 time >= 1.4 && < 1.9,

7766 transformers >= 0.2,

7867 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

8070

8171 exposed-modules:

8272 Data.AppendMap,

83− Data.Map.Misc,

73+ Data.FastMutableIntMap,

74+ Data.FastWeakBag,

8475 Data.Functor.Misc,

76+ Data.Map.Misc,

8577 Data.WeakBag,

86− Data.FastWeakBag,

87− Data.FastMutableIntMap,

8878 Generics.SOP.DMapUtilities,

8979 Generics.SOP.Distribute,

9080 Reflex,

9181 Reflex.Class,

82+ Reflex.Adjustable.Class,

83+ Reflex.BehaviorWriter.Base,

84+ Reflex.BehaviorWriter.Class,

9285 Reflex.Collection,

93− Reflex.EventWriter,

9486 Reflex.Dynamic,

9587 Reflex.Dynamic.Uniq,

9688 Reflex.Dynamic.CollectDynGeneric,

9789 Reflex.DynamicWriter,

90+ Reflex.DynamicWriter.Base,

91+ Reflex.DynamicWriter.Class,

92+ Reflex.EventWriter,

93+ Reflex.EventWriter.Base,

94+ Reflex.EventWriter.Class,

9895 Reflex.FastWeak,

9996 Reflex.FunctorMaybe,

10097 Reflex.Host.Class,

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

107104 Reflex.Patch.IntMap,

108105 Reflex.Patch.Map,

109106 Reflex.Patch.MapWithMove,

110− Reflex.TriggerEvent.Base,

111− Reflex.TriggerEvent.Class,

112107 Reflex.PerformEvent.Base,

113108 Reflex.PerformEvent.Class,

114109 Reflex.PostBuild.Base,

115110 Reflex.PostBuild.Class,

116111 Reflex.Profiled,

112+ Reflex.Pure,

117113 Reflex.Query.Base,

118114 Reflex.Query.Class,

119115 Reflex.Requester.Base,

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

121117 Reflex.Spider,

122118 Reflex.Spider.Internal,

123119 Reflex.Time,

120+ Reflex.TriggerEvent.Base,

121+ Reflex.TriggerEvent.Class,

124122 Reflex.Widget.Basic,

125123 Reflex.Workflow

126124

127− ghc-options: -Wall -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

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

134126

135127 if flag(debug-trace-events)

136128 cpp-options: -DDEBUG_TRACE_EVENTS

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

145137 cpp-options: -DUSE_TEMPLATE_HASKELL

146138 build-depends:

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

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

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

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

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

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

151143 exposed-modules:

152144 Reflex.Dynamic.TH

153145 other-extensions: TemplateHaskell

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

155147 build-depends:

156148 dependent-sum == 0.4.*

157149

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−

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

165− ghc-options: -DGHCJS_FAST_WEAK

151+ cpp-options: -DGHCJS_FAST_WEAK

166152

167153 if impl(ghcjs)

168154 build-depends: ghcjs-base

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

186172 reflex,

187173 split,

188174 transformers >= 0.3

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

190− buildable: False

175+ other-modules:

176+ Reflex.Bench.Focused

177+ Reflex.Plan.Pure

178+ Reflex.Plan.Reflex

179+ Reflex.Test

180+ Reflex.Test.Micro

181+ Reflex.TestPlan

191182

192183test-suite CrossImpl

193184 type: exitcode-stdio-1.0

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

195186 hs-source-dirs: test

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

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

197188 build-depends:

198189 base,

199190 containers,

200191 dependent-map,

192+ dependent-sum,

193+ deepseq >= 1.3 && < 1.5,

201194 mtl,

195+ transformers,

202196 ref-tf,

203197 reflex

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

205− buildable: False

198+ other-modules:

199+ Reflex.Test

200+ Reflex.TestPlan

201+ Reflex.Plan.Reflex

202+ Reflex.Plan.Pure

206203

207204test-suite hlint

208205 type: exitcode-stdio-1.0

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

215212 , hlint

216213 if impl(ghcjs)

217214 buildable: False

218− buildable: False

219215

220216test-suite EventWriterT

221217 type: exitcode-stdio-1.0

222218 main-is: EventWriterT.hs

223219 hs-source-dirs: test

224220 build-depends: base

221+ , containers

222+ , deepseq >= 1.3 && < 1.5

223+ , dependent-map

225224 , dependent-sum

226225 , lens

226+ , mtl

227227 , these

228228 , transformers

229229 , reflex

230230 , ref-tf

231+ other-modules:

232+ Reflex.Test

233+ Reflex.TestPlan

234+ Reflex.Plan.Reflex

235+ Reflex.Plan.Pure

236+ Test.Run

231237

232238test-suite RequesterT

233239 type: exitcode-stdio-1.0

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

242248 , reflex

243249 , ref-tf

244250 buildable: False

251+ other-modules:

252+ Reflex.TestPlan

253+ Reflex.Plan.Pure

245254

246255test-suite QueryT

247256 type: exitcode-stdio-1.0

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

249258 hs-source-dirs: test

250259 build-depends: base

251260 , containers

252− , dependent-sum

253261 , dependent-map

262+ , dependent-sum

263+ , deepseq >= 1.3 && < 1.5

254264 , lens

265+ , monoidal-containers

266+ , mtl

267+ , ref-tf

268+ , reflex

269+ , semigroups

255270 , these

256271 , transformers

257− , semigroups

258− , reflex

259− , ref-tf

272+ other-modules:

273+ Test.Run

274+ Reflex.TestPlan

275+ Reflex.Plan.Reflex

276+ Reflex.Plan.Pure

260277

261278test-suite GC-Semantics

262279 type: exitcode-stdio-1.0

263280 main-is: GC.hs

264281 hs-source-dirs: test

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

266− buildable: False

267282 build-depends: base

283+ , containers

268284 , dependent-sum

269285 , dependent-map

286+ , deepseq >= 1.3 && < 1.5

287+ , mtl

270288 , these

271289 , transformers

272290 , reflex

273291 , ref-tf

274292 if impl(ghc < 8)

275293 build-depends: semigroups

294+ other-modules:

295+ Reflex.Plan.Pure

296+ Reflex.Plan.Reflex

297+ Reflex.TestPlan

298+ Test.Run

276299

277300test-suite rootCleanup

278301 type: exitcode-stdio-1.0

279302 main-is: rootCleanup.hs

280303 hs-source-dirs: test

281304 build-depends: base

305+ , containers

306+ , deepseq >= 1.3 && < 1.5

307+ , dependent-sum

308+ , mtl

282309 , reflex

310+ , ref-tf

311+ , these

312+ other-modules:

313+ Reflex.Plan.Pure

314+ Reflex.TestPlan

315+ Test.Run

283316

284317test-suite mkDyn

285318 type: exitcode-stdio-1.0

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

295328

296329benchmark spider-bench

297330 type: exitcode-stdio-1.0

298− hs-source-dirs: bench

331+ hs-source-dirs: bench test

299332 main-is: Main.hs

300333 ghc-options: -Wall -O2 -rtsopts

301334 build-depends:

302335 base,

303− criterion == 1.1.*,

336+ containers,

337+ criterion >= 1.1 && < 1.6,

304338 deepseq >= 1.3 && < 1.5,

305339 dependent-map,

306340 dependent-sum,

341+ ref-tf,

307342 mtl,

308343 primitive,

309344 reflex,

345+ split,

310346 stm,

311347 transformers >= 0.3

348+ other-modules:

349+ Reflex.TestPlan

350+ Reflex.Plan.Reflex

351+ Reflex.Bench.Focused

312352

313353benchmark saulzar-bench

314354 type: exitcode-stdio-1.0

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

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

317357 main-is: RunAll.hs

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

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

320359 build-depends:

321360 base,

322− containers == 0.5.*,

323− criterion == 1.1.*,

361+ containers >= 0.5 && < 0.7,

362+ criterion >= 1.1 && < 1.6,

324363 deepseq >= 1.3 && < 1.5,

325364 dependent-map,

326365 dependent-sum,

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

334373 stm,

335374 time,

336375 transformers >= 0.3

376+ other-modules:

377+ Reflex.TestPlan

378+ Reflex.Plan.Reflex

379+ Reflex.Bench.Focused

337380

338381source-repository head

339382 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 #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DeriveTraversable #-}

1+{-# LANGUAGE CPP #-}

42{-# LANGUAGE FlexibleContexts #-}

53{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

74{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE PatternSynonyms #-}

86{-# LANGUAGE RoleAnnotations #-}

97{-# LANGUAGE ScopedTypeVariables #-}

108{-# LANGUAGE TypeFamilies #-}

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

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

1211--

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

1413-- @mappend = unionWith mappend@ instead.

15−module Data.AppendMap where

14+module Data.AppendMap

15+ ( module Data.AppendMap

16+ , module Data.Map.Monoidal

17+ ) where

1618

17−import Prelude hiding (map)

19+import Prelude hiding (map, null)

1820

19−import Control.Lens

20−import Data.Align

2121import Data.Coerce

2222import Data.Default

2323import Data.Map (Map)

24−import qualified Data.Map as Map

25−import Data.Semigroup

26−import Data.Set (Set)

27−import Data.Typeable

28−import GHC.Generics (Generic)

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

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

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

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

26+#else

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

28+#endif

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

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

31+import qualified Data.Map.Monoidal as M

3132

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

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

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

34+type AppendMap = MonoidalMap

3435

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

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

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

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

38+_unAppendMap = getMonoidalMap

3739

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

39− ix i = _Wrapped . ix i

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

41+pattern AppendMap m = MonoidalMap m

4042

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

42− at i = _Wrapped . at i

43−

44−instance FunctorMaybe (AppendMap k) where

45− fmapMaybe = mapMaybe

43+instance Filterable (MonoidalMap k) where

44+ mapMaybe = M.mapMaybe

4645

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

4948nonEmptyDelete k vs =

5049 let deleted = delete k vs

51− in if Data.AppendMap.null deleted

50+ in if null deleted

5251 then Nothing

5352 else Just deleted

5453

5554mapMaybeNoNull :: (a -> Maybe b)

56− -> AppendMap token a

57− -> Maybe (AppendMap token b)

55+ -> MonoidalMap token a

56+ -> Maybe (MonoidalMap token b)

5857mapMaybeNoNull f as =

59− let bs = fmapMaybe f as

60− in if Data.AppendMap.null bs

58+ let bs = mapMaybe f as

59+ in if null bs

6160 then Nothing

6261 else Just bs

6362

64−instance FunctorWithIndex k (AppendMap k) where

65− imap f = AppendMap . imap f . _unAppendMap

66− imapped = _Wrapped . imapped

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)

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

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

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

23566

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

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

39769

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

40271 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 #-}

51{-# LANGUAGE TypeFamilies #-}

62module Data.FastMutableIntMap

73 ( FastMutableIntMap

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

2622--TODO: Fast copy to FastIntMap

2723--TODO: Fast patch type

2824

25+import Prelude hiding (lookup)

26+

2927import Control.Monad.IO.Class

3028import Data.Foldable (traverse_)

31−import Data.IORef

3229import Data.IntMap.Strict (IntMap)

3330import qualified Data.IntMap.Strict as IntMap

34−import Data.Maybe

35−import Prelude hiding (lookup)

31+import Data.IORef

3632import Reflex.Patch.Class

3733import Reflex.Patch.IntMap

3834

src/Data/FastWeakBag.hs+6−7

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

2626#endif

2727 ) where

2828

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

29+import Prelude hiding (traverse)

30+

31+import Control.Monad

3032import Control.Monad.IO.Class

3133

3234#ifdef GHCJS_FAST_WEAK

3335import GHCJS.Types

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

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

3537#else

3638import Control.Exception

37−import Data.Foldable (forM_, mapM_)

3839import Data.IntMap.Strict (IntMap)

3940import qualified Data.IntMap.Strict as IntMap

4041import Data.IORef

4142import System.Mem.Weak

4243#endif

4344

44−import Prelude hiding (mapM_, traverse)

45−

46−-- | A @FastWeakBag a@ 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

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

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

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

4948#ifdef GHCJS_FAST_WEAK

5049newtype FastWeakBag a = FastWeakBag JSVal

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

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

3838 , dmapToThese

3939 , eitherToDSum

4040 , dsumToEither

41− -- * Deprecated functions

42− , sequenceDmap

43− , wrapDMap

44− , rewrapDMap

45− , unwrapDMap

46− , unwrapDMapMaybe

47− , extractFunctorDMap

4841 , ComposeMaybe (..)

4942 ) where

5043

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

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

5245import Control.Monad.Identity

5346import Data.Dependent.Map (DMap)

5447import qualified Data.Dependent.Map as DMap

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

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

8578

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

87−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

88− gshowToShow (Const2 _) = id

89−#else

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

91−#endif

9281

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

94−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

95− showTagToShow (Const2 _) _ = id

96−#else

9783 showTaggedPrec (Const2 _) = showsPrec

98−#endif

9984

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

101−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

102− geqToEq _ = id

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

104−#else

10586 geq (Const2 a) (Const2 b) =

10687 if a == b

10788 then Just Refl

10889 else Nothing

109−#endif

11090

11191instance 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

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

11793 LT -> GLT

11894 EQ -> GEQ

11995 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

12996

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

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

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

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

176143

177144instance 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

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

183−#endif

184146

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

186−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

187− gcompareToOrd (WrapArg f) = gcompareToOrd f

188−#endif

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

190149 GLT -> GLT

191150 GEQ -> GEQ

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

237196deriving instance Eq (EitherTag l r a)

238197deriving instance Ord (EitherTag l r a)

239198

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−

252199instance 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

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

260201 (LeftTag, LeftTag) -> Just Refl

261202 (RightTag, RightTag) -> Just Refl

262203 _ -> Nothing

263204

264205instance GCompare (EitherTag l r) where

265−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

266− gcompareToOrd _ = id

267−#endif

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

269207 (LeftTag, LeftTag) -> GEQ

270208 (LeftTag, RightTag) -> GLT

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

272210 (RightTag, RightTag) -> GEQ

273211

274212instance GShow (EitherTag l r) where

275−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

276− gshowToShow _ = id

277−#else

278213 gshowsPrec _ a = case a of

279214 LeftTag -> showString "LeftTag"

280215 RightTag -> showString "RightTag"

281−#endif

282216

283217instance (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

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

290219 LeftTag -> showsPrec n a

291220 RightTag -> showsPrec n a

292−#endif

293221

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

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

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

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

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

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

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

314241newtype 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)

319243

320244deriving 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 @@

11{-# LANGUAGE LambdaCase #-}

2−module Data.Map.Misc

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

3+module Data.Map.Misc

34 (

45 -- * Working with Maps

56 diffMapNoEq

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

1011 ) where

1112

1213import Data.Align

13−import Data.Either

1414import Data.Map (Map)

1515import qualified Data.Map as Map

1616import Data.Maybe

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

1818import qualified Data.Set as Set

1919import Data.These

2020

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.

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

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

2327 This _ -> Just Nothing

2428 These _ new -> Just $ Just new

2529 That new -> Just $ Just new

2630

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@.

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

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

2938 This _ -> Just Nothing

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

3241 | otherwise -> Just $ Just new

3342 That new -> Just $ Just new

3443

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

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

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

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

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

3850 maybeToEither = \case

3951 Nothing -> Left ()

4052 Just r -> Right r

4153

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" #-}

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

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

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"

57+mapPartitionEithers = Map.mapEither id

4958

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

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

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+-- @

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

65+-- @

66+--

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

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

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

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

src/Data/WeakBag.hs+5−8

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

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

2222 ) where

2323

24+import Prelude hiding (traverse)

25+

2426import Control.Exception

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

27+import Control.Monad

2628import Control.Monad.IO.Class

27−import Data.Foldable (forM_, mapM_)

2829import Data.IntMap.Strict (IntMap)

2930import qualified Data.IntMap.Strict as IntMap

3031import Data.IORef

3132import System.Mem.Weak

3233

33−import Prelude hiding (mapM_, traverse)

34−

35−-- | A @WeakBag a@ 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

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

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

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

3837data WeakBag a = WeakBag

3938 { _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

7271 let !csWithoutMe = IntMap.delete myId cs

7372 in (csWithoutMe, csWithoutMe)

7473 when (IntMap.null csWithoutMe) $ finalizer b

75− return ()

76− return ()

7774 wa <- mkWeakPtr a' $ Just cleanup

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

7976 return $ WeakBagTicket

src/Reflex.hs+8−2

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

66 ) where

88import 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

912import Reflex.Collection as X

10−import Reflex.EventWriter as X

1113import Reflex.Dynamic as X

14+import Reflex.EventWriter.Base as X

15+import Reflex.EventWriter.Class as X

1216#ifdef USE_TEMPLATE_HASKELL

1317import Reflex.Dynamic.TH as X

1418#endif

1519import 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

1723import Reflex.PerformEvent.Base as X

1824import Reflex.PerformEvent.Class as X

1925import Reflex.PostBuild.Base as X

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

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

35{-# LANGUAGE LambdaCase #-}

4−{-# LANGUAGE RecursiveDo #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

1111#ifdef USE_REFLEX_OPTIMIZER

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

1313#endif

14−module Reflex.Adjustable.Class

15− (

14+module Reflex.Adjustable.Class

15+ (

1616 -- * The Adjustable typeclass

1717 Adjustable(..)

1818 , sequenceDMapWithAdjust

1919 , sequenceDMapWithAdjustWithMove

2020 , mapMapWithAdjustWithMove

21− -- * Widgets on Collections

22− , listHoldWithKey

23− , listWithKey

24− , listWithKey'

25− , listWithKeyShallowDiff

26− , listViewWithKey

27− , selectViewListWithKey

28− , selectViewListWithKey_

29− -- * List Utils

30− , list

31− , simpleList

21+ -- * Deprecated aliases

22+ , MonadAdjust

3223 ) where

3324

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

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

36−import Data.Align

37−import Data.Map (Map)

38−import qualified Data.Map as Map

25+import Control.Monad.Identity

26+import Control.Monad.Reader

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

28+import qualified Data.Dependent.Map as DMap

4029import Data.Functor.Constant

4130import Data.Functor.Misc

42−import Data.Map.Misc

43−import Data.These

31+import Data.IntMap.Strict (IntMap)

32+import qualified Data.IntMap.Strict as IntMap

33+import Data.Map (Map)

4434

4535import Reflex.Class

46−import Reflex.Dynamic

47−import Reflex.PostBuild.Class

36+import Reflex.Patch.DMapWithMove

4837

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

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

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

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

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

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

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

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

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

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

45+ runWithReplace

46+ :: m a

47+ -> Event t (m b)

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

49+

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+

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)

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

6082

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

6284 runWithReplace a0 a' = do

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

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

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

85107

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

87−listHoldWithKey m0 m' f = do

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

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)

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

109+-- Deprecated functions

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

163111

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

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

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

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

113+type MonadAdjust = Adjustable

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 #-}

22{-# LANGUAGE CPP #-}

3+{-# LANGUAGE ConstraintKinds #-}

34{-# LANGUAGE DefaultSignatures #-}

45{-# LANGUAGE FlexibleContexts #-}

56{-# LANGUAGE FlexibleInstances #-}

@@ -8,6 +9,7 @@

89{-# LANGUAGE LambdaCase #-}

910{-# LANGUAGE MultiParamTypeClasses #-}

1011{-# LANGUAGE NoMonomorphismRestriction #-}

12+{-# LANGUAGE PolyKinds #-}

1113{-# LANGUAGE RankNTypes #-}

1214{-# LANGUAGE RecursiveDo #-}

1315{-# LANGUAGE RoleAnnotations #-}

@@ -18,14 +20,14 @@

1820#ifdef USE_REFLEX_OPTIMIZER

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

2022#endif

21−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

22−{-# LANGUAGE EmptyDataDecls #-}

23−{-# OPTIONS_GHC -Wno-redundant-constraints #-}

24−#endif

2523

26−-- | This module contains the Reflex interface, as well as a variety of

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

28−-- signals.

24+-- |

25+-- Module:

26+-- Reflex.Class

27+-- Description:

28+-- This module contains the Reflex interface, as well as a variety of

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

30+-- signals.

2931module Reflex.Class

3032 ( module Reflex.Patch

3133 -- * Primitives

@@ -36,19 +38,22 @@ module Reflex.Class

3638 , coerceDynamic

3739 , MonadSample (..)

3840 , MonadHold (..)

39− -- ** 'fan'-related types

41+ -- ** 'fan' related types

4042 , EventSelector (..)

4143 , EventSelectorInt (..)

42− -- ** 'Incremental'-related types

4344 -- * Convenience functions

4445 , constDyn

4546 , pushAlways

4647 -- ** Combining 'Event's

4748 , leftmost

4849 , mergeMap

50+ , mergeIntMap

4951 , mergeMapIncremental

5052 , mergeMapIncrementalWithMove

5153 , mergeIntMapIncremental

54+ , coincidencePatchMap

55+ , coincidencePatchMapWithMove

56+ , coincidencePatchIntMap

5257 , mergeList

5358 , mergeWith

5459 , difference

@@ -62,11 +67,16 @@ module Reflex.Class

6267 , EitherTag (..)

6368 , eitherToDSum

6469 , dsumToEither

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

66− , switchPromptly

67− , switchPromptOnly

70+ , factorEvent

71+ , filterEventKey

72+ -- ** Collapsing 'Event . Event'

73+ , switchHold

74+ , switchHoldPromptly

75+ , switchHoldPromptOnly

76+ , switchHoldPromptOnlyIncremental

6877 -- ** Using 'Event's to sample 'Behavior's

6978 , tag

79+ , tagMaybe

7080 , attach

7181 , attachWith

7282 , attachWithMaybe

@@ -100,6 +110,14 @@ module Reflex.Class

100110 , mapAccumM_

101111 , mapAccumMaybe_

102112 , mapAccumMaybeM_

113+ , accumIncremental

114+ , accumMIncremental

115+ , accumMaybeIncremental

116+ , accumMaybeMIncremental

117+ , mapAccumIncremental

118+ , mapAccumMIncremental

119+ , mapAccumMaybeIncremental

120+ , mapAccumMaybeMIncremental

103121 , zipListWithEvent

104122 , numberOccurrences

105123 , numberOccurrencesFrom

@@ -109,6 +127,9 @@ module Reflex.Class

109127 , tailE

110128 , headTailE

111129 , takeWhileE

130+ , takeWhileJustE

131+ , dropWhileE

132+ , takeDropWhileJustE

112133 , switcher

113134 -- * Debugging functions

114135 , traceEvent

@@ -116,25 +137,24 @@ module Reflex.Class

116137 -- * Unsafe functions

117138 , unsafeDynamic

118139 , unsafeMapIncremental

119− -- * 'FunctorMaybe'

120− , FunctorMaybe (..)

140+ -- * 'Filterable' convenience functions

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

121144 , fforMaybe

122145 , ffilter

123146 , filterLeft

124147 , filterRight

125− -- * 'Adjustable'

126− , Adjustable(..)

127− , sequenceDMapWithAdjust

128− , sequenceDMapWithAdjustWithMove

129− , mapMapWithAdjustWithMove

130148 -- * Miscellaneous convenience functions

131149 , ffor

150+ , ffor2

151+ , ffor3

132152 -- * Deprecated functions

133− , MonadAdjust

134− , appendEvents

135− , onceE

136− , sequenceThese

153+ , switchPromptly

154+ , switchPromptOnly

155+ -- * "Cheap" functions

137156 , fmapMaybeCheap

157+ , mapMaybeCheap

138158 , fmapCheap

139159 , fforCheap

140160 , fforMaybeCheap

@@ -144,97 +164,51 @@ module Reflex.Class

144164 , mergeWithCheap'

145165 -- * Slow, but general, implementations

146166 , 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

178167 ) where

179168

180169import Control.Applicative

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

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

183−import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

184−import Control.Monad.Trans.Cont (ContT ())

185−import Control.Monad.Trans.Except (ExceptT ())

186−import Control.Monad.Trans.RWS (RWST ())

187−import Control.Monad.Trans.Writer (WriterT ())

170+import Control.Monad.Identity

171+import Control.Monad.Reader

172+import Control.Monad.State.Strict

173+import Control.Monad.Trans.Cont (ContT)

174+import Control.Monad.Trans.Except (ExceptT)

175+import Control.Monad.Trans.RWS (RWST)

176+import Control.Monad.Trans.Writer (WriterT)

188177import Data.Align

189178import Data.Bifunctor

190179import Data.Coerce

191180import Data.Default

192−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

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

193182import 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)

195187import Data.Foldable

196−import Data.Functor.Bind hiding (join)

197−import qualified Data.Functor.Bind as Bind

198−import Data.Functor.Constant

188+import Data.Functor.Bind

199189import Data.Functor.Misc

200190import Data.Functor.Plus

201191import Data.IntMap.Strict (IntMap)

202192import qualified Data.IntMap.Strict as IntMap

203193import Data.List.NonEmpty (NonEmpty (..))

204194import Data.Map (Map)

205−import Data.Maybe

206−import Data.Monoid hiding (Alt, (<>))

207195import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

196+import Data.Some (Some)

197+import qualified Data.Some as Some

208198import Data.String

209199import Data.These

210−import Data.Traversable

211200import Data.Type.Coercion

212−import Reflex.FunctorMaybe

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

202+import qualified Data.Witherable as W

203+import Reflex.FunctorMaybe (FunctorMaybe)

204+import qualified Reflex.FunctorMaybe

213205import Reflex.Patch

214−import Data.FastMutableIntMap (PatchIntMap)

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

206+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

229207

230208import Debug.Trace (trace)

231209

232−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

233−#include "Spider/SpiderTimeline.include.hs"

234−#endif

235−

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

238212-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

239213-- and the type of the timeline determines the FRP engine to be used. For most

240214-- purposes, the 'Reflex.Spider' implementation is recommended.

@@ -244,9 +218,6 @@ class ( MonadHold t (PushM t)

244218 , Functor (Dynamic t)

245219 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

246220 , Monad (Dynamic t)

247−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

248− , t ~ SpiderTimeline Global

249−#endif

250221 ) => Reflex t where

251222 -- | A container for a value that can change over time. 'Behavior's can be

252223 -- sampled at will, but it is not possible to be notified when they change

@@ -269,7 +240,6 @@ class ( MonadHold t (PushM t)

269240 type PushM t :: * -> *

270241 -- | A monad for doing complex pull-based calculations efficiently

271242 type PullM t :: * -> *

272−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

273243 -- | An 'Event' with no occurrences

274244 never :: Event t a

275245 -- | Create a 'Behavior' that always has the given value

@@ -284,7 +254,7 @@ class ( MonadHold t (PushM t)

284254 -- recomputed whenever any of the read 'Behavior's changes

285255 pull :: PullM t a -> Behavior t a

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

288258 -- that are occurring simultaneously

289259 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

290260 -- | Efficiently fan-out an event to many destinations. This function should

@@ -294,8 +264,7 @@ class ( MonadHold t (PushM t)

294264 -- | Create an 'Event' that will occur whenever the currently-selected input

295265 -- 'Event' occurs

296266 switch :: Behavior t (Event t a) -> Event t a

297− -- | Create an 'Event' that will occur whenever the input event is occurring

298− -- and its occurrence value, another 'Event', is also occurring

267+ -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring

299268 coincidence :: Event t (Event t a) -> Event t a

300269 -- | Extract the 'Behavior' of a 'Dynamic'.

301270 current :: Dynamic t a -> Behavior t a

@@ -304,7 +273,7 @@ class ( MonadHold t (PushM t)

304273 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

305274 -- recent firing of the given 'Event', if any.

306275 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

308277 -- in the same way that the accumulated application of patches would change

309278 -- that value.

310279 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

@@ -329,84 +298,11 @@ class ( MonadHold t (PushM t)

329298 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

330299 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

331300 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

332−#endif

333301

334302--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

335303mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

336304mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

337305

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−

410306-- | Coerce a 'Behavior' between representationally-equivalent value types

411307coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

412308coerceBehavior = coerceWith $ behaviorCoercion Coercion

@@ -420,7 +316,7 @@ coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

420316coerceDynamic = coerceWith $ dynamicCoercion Coercion

421317

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

424320-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

425321-- if this is not the case, the resulting 'Dynamic' will behave

426322-- nondeterministically.

@@ -448,7 +344,7 @@ class MonadSample t m => MonadHold t m where

448344 -- value and will be updated whenever the given 'Event' occurs. The update

449345 -- takes effect immediately after the 'Event' occurs; if the occurrence that

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

452348 -- one.

453349 hold :: a -> Event t a -> m (Behavior t a)

454350 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

463359 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

464360 default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

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

467363 {-

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

469365 buildDynamic getV0 = lift . buildDynamic getV0

470366 -}

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

472368 -- the supplied 'Event'.

473369 headE :: Event t a -> m (Event t a)

474370

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

475400

476401slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

477402slowHeadE e = do

@@ -481,14 +406,14 @@ slowHeadE e = do

481406

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

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

484−-- 'fmapMaybe'.

409+-- 'mapMaybe'.

485410newtype EventSelector t k = EventSelector

486411 { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is

487412 -- determined by the type of the key, so this can be used to fan-out

488413 -- 'Event's whose sub-'Event's have different types.

489414 --

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

492417 -- occurrences of an 'Event'.

493418 select :: forall a. k a -> Event t a

494419 }

@@ -572,6 +497,14 @@ pushAlways f = push (fmap Just . f)

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

573498ffor = flip fmap

574499

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+

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

576509 pure = constant

577510 f <*> x = pull $ sample f `ap` sample x

@@ -615,6 +548,15 @@ instance (Reflex t, Num a) => Num (Behavior t a) where

615548 negate = fmap negate

616549 signum = fmap signum

617550

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+

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

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

620562 sconcat = pull . fmap sconcat . mapM sample

@@ -624,22 +566,25 @@ instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

624566 times1p n = fmap $ times1p n

625567#endif

626568

627−-- | Flipped version of 'fmapMaybe'.

628−fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b

629−fforMaybe = flip fmapMaybe

569+-- | Alias for 'mapMaybe'

570+fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b

571+fmapMaybe = mapMaybe

572+

573+-- | Flipped version of 'mapMaybe'.

574+fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b

575+fforMaybe = flip mapMaybe

630576

631577-- | Filter 'f a' using the provided predicate.

632−-- Relies on 'fforMaybe'.

633−ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a

634−ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing

578+ffilter :: Filterable f => (a -> Bool) -> f a -> f a

579+ffilter = W.filter

635580

636581-- | Filter 'Left's from 'f (Either a b)' into 'a'.

637−filterLeft :: FunctorMaybe f => f (Either a b) -> f a

638−filterLeft = fmapMaybe (either Just (const Nothing))

582+filterLeft :: Filterable f => f (Either a b) -> f a

583+filterLeft = mapMaybe (either Just (const Nothing))

639584

640585-- | Filter 'Right's from 'f (Either a b)' into 'b'.

641−filterRight :: FunctorMaybe f => f (Either a b) -> f b

642−filterRight = fmapMaybe (either (const Nothing) Just)

586+filterRight :: Filterable f => f (Either a b) -> f b

587+filterRight = mapMaybe (either (const Nothing) Just)

643588

644589-- | Left-biased event union (prefers left event on simultaneous

645590-- occurrence).

@@ -657,13 +602,18 @@ instance Reflex t => Bind (Event t) where

657602

658603instance Reflex t => Functor (Event t) where

659604 {-# INLINE fmap #-}

660− fmap f = fmapMaybe $ Just . f

605+ fmap f = mapMaybe $ Just . f

661606 {-# INLINE (<$) #-}

662607 x <$ e = fmapCheap (const x) e

663608

609+-- TODO Remove this instance

664610instance Reflex t => FunctorMaybe (Event t) where

665611 {-# INLINE fmapMaybe #-}

666− fmapMaybe f = push $ return . f

612+ fmapMaybe = mapMaybe

613+

614+instance Reflex t => Filterable (Event t) where

615+ {-# INLINE mapMaybe #-}

616+ mapMaybe f = push $ return . f

667617

668618-- | Never: @'zero' = 'never'@.

669619instance Reflex t => Plus (Event t) where

@@ -674,7 +624,13 @@ instance Reflex t => Plus (Event t) where

674624tag :: Reflex t => Behavior t b -> Event t a -> Event t b

675625tag b = pushAlways $ \_ -> sample b

676626

677−-- | Create a new 'Event' that combines occurences of supplied 'Event' with the

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+

633+-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the

678634-- current value of the 'Behavior'.

679635attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

680636attach = attachWith (,)

@@ -684,53 +640,118 @@ attach = attachWith (,)

684640attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

685641attachWith f = attachWithMaybe $ \a b -> Just $ f a b

686642

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

688644-- the 'Behavior'. The occurrence is discarded if the combining function returns

689645-- Nothing

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

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

692648

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

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

696652tailE e = snd <$> headTailE e

697653

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

699−-- time the supplied 'Event' occurs and the second occuring on all but the first

700−-- occurence.

701−headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)

654+-- | Create a tuple of two 'Event's with the first one occurring only the first

655+-- time the supplied 'Event' occurs and the second occurring on all but the first

656+-- occurrence.

657+headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)

702658headTailE e = do

703659 eHead <- headE e

704660 be <- hold never $ fmap (const e) eHead

705661 return (eHead, switch be)

706662

707−-- | 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

709−-- fire, and permanently stop firing, even if 'True' values are encountered

710−-- later.

711−takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)

712−takeWhileE f e = do

713− rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a

714− then Right a

715− else Left never

716− be <- hold e eFalse

717− let e' = switch be

663+-- | Take the streak of occurrences starting at the current time for which the

664+-- event returns 'True'.

665+--

666+-- Starting at the current time, fire all the occurrences of the 'Event' for

667+-- which the given predicate returns 'True'. When first 'False' is returned,

668+-- do not fire, and permanently stop firing, even if 'True' values would have

669+-- been encountered later.

670+takeWhileE

671+ :: forall t m a

672+ . (Reflex t, MonadFix m, MonadHold t m)

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

692+ rec let (eBad, eTrue) = fanEither $ ffor e' $ \a -> case f a of

693+ Nothing -> Left never

694+ Just b -> Right b

695+ eFirstBad <- headE eBad

696+ e' <- switchHold e eFirstBad

718697 return eTrue

719698

720−-- | Split the supplied 'Event' into two individual 'Event's occuring at the

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+

741+-- | Split the supplied 'Event' into two individual 'Event's occurring at the

721742-- same time with the respective values from the tuple.

722743splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

723744splitE e = (fmap fst e, fmap snd e)

724745

725746-- | 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.

727748--

728749-- Note: As with Debug.Trace.trace, the message will only be printed if the

729750-- 'Event' is actually used.

730751traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

731752traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

732753

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

734755-- 'Event'. This should /only/ be used for debugging.

735756--

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

774795leftmost = mergeWith const

775796

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

778799-- time.

779800mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

780801mergeList [] = never

@@ -785,10 +806,14 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn

785806

786807-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

787808-- 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.

789810mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

790811mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

791812

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+

792817-- | Create a merge whose parents can change over time

793818mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

794819mergeMapIncremental = 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)

806831fanEither e =

807832 let justLeft = either Just (const Nothing)

808833 justRight = either (const Nothing) Just

809− in (fmapMaybe justLeft e, fmapMaybe justRight e)

834+ in (mapMaybe justLeft e, mapMaybe justRight e)

810835

811836-- | Split the event into separate events for 'This' and 'That' values,

812837-- allowing them to fire simultaneously when the input value is 'These'.

@@ -818,43 +843,114 @@ fanThese e =

818843 that (That y) = Just y

819844 that (These _ y) = Just y

820845 that _ = Nothing

821− in (fmapMaybe this e, fmapMaybe that e)

846+ in (mapMaybe this e, mapMaybe that e)

822847

823848-- | Split the event into an 'EventSelector' that allows efficient selection of

824849-- the individual 'Event's.

825850fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

826851fanMap = fan . fmap mapToDMap

827852

828−-- | Switches to the new event whenever it receives one. Whenever a new event

829−-- is provided, if it is firing, its value will be the resulting event's value;

830−-- if it is not firing, but the old one is, the old one's value will be used.

831−switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

832−switchPromptly ea0 eea = do

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

867+-- provided, if it is firing, its value will be the resulting event's value; if

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.

874+switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

875+switchHoldPromptly ea0 eea = do

833876 bea <- hold ea0 eea

834877 let eLag = switch bea

835878 eCoincidences = coincidence eea

836879 return $ leftmost [eCoincidences, eLag]

837880

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

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

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

841884-- old value.

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

843−switchPromptOnly e0 e' = do

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.

890+switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

891+switchHoldPromptOnly e0 e' = do

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

845893 return $ coincidence $ leftmost [e', eLag <$ eLag]

846894

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+

847943instance Reflex t => Align (Event t) where

848944 nil = never

849945 align = alignEventWithMaybe Just

850946

851947-- | 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.

853949gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

854950gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

855951

856−-- | Create a new behavior given a starting behavior and switch to a the behvior

857−-- carried by the event when it fires.

952+-- | Create a new behavior given a starting behavior and switch to the behavior

953+-- carried by the event when it fires.

858954switcher :: (Reflex t, MonadHold t m)

859955 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

860956switcher b eb = pull . (sample <=< sample) <$> hold b eb

@@ -869,7 +965,7 @@ zipDyn = zipDynWith (,)

869965

870966-- | Combine two 'Dynamic's with a combining function. The result will change

871967-- whenever either (or both) input 'Dynamic' changes.

872−-- More efficient than liftA2.

968+-- More efficient than 'liftA2'.

873969zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

874970zipDynWith f da db =

875971 let eab = align (updated da) (updated db)

@@ -885,6 +981,14 @@ zipDynWith f da db =

885981 return $ Just $ f a b

886982 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

887983

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+

888992instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

889993 mconcat = distributeListOverDynWith mconcat

890994 mempty = constDyn mempty

@@ -892,7 +996,7 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

892996

893997-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

894998-- '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.

8961000distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

8971001distributeDMapOverDynPure dm = case DMap.toList dm of

8981002 [] -> constDyn DMap.empty

@@ -918,14 +1022,57 @@ distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) .

9181022difference :: Reflex t => Event t a -> Event t b -> Event t a

9191023difference = alignEventWithMaybe $ \case

9201024 This a -> Just a

921− _ -> Nothing

1025+ _ -> Nothing

9221026

1027+-- | Zips two values by taking the union of their shapes and combining with the provided function.

1028+-- 'Nothing' values are dropped.

9231029alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c

924−alignEventWithMaybe f ea eb =

925− fmapMaybe (f <=< dmapToThese)

926− $ merge

927− $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

928−

1030+alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $

1031+ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

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)

9291076

9301077--------------------------------------------------------------------------------

9311078-- Accumulator

@@ -955,26 +1102,94 @@ class Reflex t => Accumulator t f | f -> t where

9551102 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

9561103 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)

9571104

958−accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)

1105+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1106+-- with the provided function. See 'foldDyn'.

1107+accumDyn

1108+ :: (Reflex t, MonadHold t m, MonadFix m)

1109+ => (a -> b -> a)

1110+ -> a

1111+ -> Event t b

1112+ -> m (Dynamic t a)

9591113accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o

960−accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)

1114+

1115+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1116+-- with the provided 'PushM' action.

1117+accumMDyn

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)

9611123accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o

962−accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)

1124+

1125+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1126+-- with the provided function, discarding 'Nothing' results.

1127+accumMaybeDyn

1128+ :: (Reflex t, MonadHold t m, MonadFix m)

1129+ => (a -> b -> Maybe a)

1130+ -> a

1131+ -> Event t b

1132+ -> m (Dynamic t a)

9631133accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o

964−accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)

1134+

1135+-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1136+-- with the provided 'PushM' action, discarding 'Nothing' results.

1137+accumMaybeMDyn

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)

9651143accumMaybeMDyn f z e = do

9661144 rec let e' = flip push e $ \o -> do

9671145 v <- sample $ current d'

9681146 f v o

9691147 d' <- holdDyn z e'

9701148 return d'

971−mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)

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

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)

9721159mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o

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)

1160+

1161+-- | Similar to 'mapAccumDyn' except that the combining function is a

1162+-- 'PushM' action.

1163+mapAccumMDyn

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)

9741169mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o

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)

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

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)

9761183mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o

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)

1184+

1185+-- | Like 'mapAccumMaybeDyn' except that the combining function is a

1186+-- 'PushM' action.

1187+mapAccumMaybeMDyn

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)

9781193mapAccumMaybeMDyn f z e = do

9791194 rec let e' = flip push e $ \o -> do

9801195 v <- sample $ current d'

@@ -982,18 +1197,42 @@ mapAccumMaybeMDyn f z e = do

9821197 return $ case result of

9831198 (Nothing, Nothing) -> Nothing

9841199 _ -> Just result

985− d' <- holdDyn z $ fmapMaybe fst e'

986− return (d', fmapMaybe snd e')

1200+ d' <- holdDyn z $ mapMaybe fst e'

1201+ return (d', mapMaybe snd e')

9871202

1203+-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1204+-- with the provided function.

9881205{-# INLINE accumB #-}

989−accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)

1206+accumB

1207+ :: (Reflex t, MonadHold t m, MonadFix m)

1208+ => (a -> b -> a)

1209+ -> a

1210+ -> Event t b

1211+ -> m (Behavior t a)

9901212accumB f = accumMaybeB $ \v o -> Just $ f v o

1213+

1214+-- | Like 'accumB' except that the combining function is a 'PushM' action.

9911215{-# INLINE accumMB #-}

992−accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)

1216+accumMB

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)

9931222accumMB 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.

9941226{-# INLINE accumMaybeB #-}

995−accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)

1227+accumMaybeB

1228+ :: (Reflex t, MonadHold t m, MonadFix m)

1229+ => (a -> b -> Maybe a)

1230+ -> a

1231+ -> Event t b

1232+ -> m (Behavior t a)

9961233accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o

1234+

1235+-- | Like 'accumMaybeB' except that the combining function is a 'PushM' action.

9971236{-# INLINE accumMaybeMB #-}

9981237accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)

9991238accumMaybeMB f z e = do

@@ -1002,16 +1241,42 @@ accumMaybeMB f z e = do

10021241 f v o

10031242 d' <- hold z e'

10041243 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'.

10051248{-# INLINE 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)

1249+mapAccumB

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)

10071255mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o

1256+

1257+-- | Like 'mapAccumB' except that the combining function is a 'PushM' action.

10081258{-# INLINE 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)

1259+mapAccumMB

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)

10101265mapAccumMB 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.

10111270{-# INLINE 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)

1271+mapAccumMaybeB

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)

10131277mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o

10141278

1279+-- | LIke 'mapAccumMaybeB' except that the combining function is a 'PushM' action.

10151280{-# INLINE mapAccumMaybeMB #-}

10161281mapAccumMaybeMB :: (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)

10171282mapAccumMaybeMB f z e = do

@@ -1021,8 +1286,8 @@ mapAccumMaybeMB f z e = do

10211286 return $ case result of

10221287 (Nothing, Nothing) -> Nothing

10231288 _ -> Just result

1024− d' <- hold z $ fmapMaybe fst e'

1025− return (d', fmapMaybe snd e')

1289+ d' <- hold z $ mapMaybe fst e'

1290+ return (d', mapMaybe snd e')

10261291

10271292-- | Accumulate occurrences of an 'Event', producing an output occurrence each

10281293-- time. Discard the underlying 'Accumulator'.

@@ -1069,7 +1334,7 @@ instance Reflex t => Accumulator t (Event t) where

10691334 accumMaybeM f z e = updated <$> accumMaybeM f z e

10701335 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

10711336

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

10731338-- list using the supplied function. If the list runs out of items, all

10741339-- subsequent 'Event' occurrences will be ignored.

10751340zipListWithEvent :: (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

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

10801345 mapAccumMaybe_ f' l e

10811346

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

10831348{-# INLINE numberOccurrences #-}

10841349numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

10851350numberOccurrences = numberOccurrencesFrom 0

10861351

1087−-- | Assign a number to each occurence of the given 'Event'

1352+-- | Assign a number to each occurrence of the given 'Event'

10881353{-# INLINE numberOccurrencesFrom #-}

10891354numberOccurrencesFrom :: (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)))

10911356

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

10931358{-# INLINE numberOccurrencesFrom_ #-}

10941359numberOccurrencesFrom_ :: (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))

10961361

10971362-- | This is used to sample the value of a 'Behavior' using an 'Event'.

10981363--

@@ -1162,83 +1427,57 @@ infixl 4 <@>

11621427(<@) = tag

11631428infixl 4 <@

11641429

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−

12061430------------------

12071431-- Cheap Functions

12081432------------------

12091433

1434+-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'.

12101435{-# INLINE pushAlwaysCheap #-}

12111436pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

12121437pushAlwaysCheap f = pushCheap (fmap Just . f)

12131438

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'

12141445{-# INLINE fmapMaybeCheap #-}

12151446fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1216−fmapMaybeCheap f = pushCheap $ return . f

1447+fmapMaybeCheap = mapMaybeCheap

12171448

1449+

1450+-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'.

12181451{-# INLINE fforMaybeCheap #-}

12191452fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

1220−fforMaybeCheap = flip fmapMaybeCheap

1453+fforMaybeCheap = flip mapMaybeCheap

12211454

1455+-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'.

12221456{-# INLINE fforCheap #-}

12231457fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

12241458fforCheap = flip fmapCheap

12251459

1460+-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'.

12261461{-# INLINE fmapCheap #-}

12271462fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

12281463fmapCheap f = pushCheap $ return . Just . f

12291464

1465+-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'.

12301466{-# INLINE tagCheap #-}

12311467tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

12321468tagCheap b = pushAlwaysCheap $ \_ -> sample b

12331469

1470+-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

12341471{-# INLINE mergeWithCheap #-}

12351472mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

12361473mergeWithCheap = mergeWithCheap' id

12371474

1475+-- | A "cheap" version of 'mergeWithCheap''. See the performance note on 'pushCheap'.

12381476{-# INLINE mergeWithCheap' #-}

12391477mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

12401478mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

12411479

1480+-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.

12421481{-# INLINE mergeWithFoldCheap' #-}

12431482mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

12441483mergeWithFoldCheap' f es =

@@ -1251,27 +1490,9 @@ mergeWithFoldCheap' f es =

12511490-- Deprecated functions

12521491--------------------------------------------------------------------------------

12531492

1254−{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}

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

1261−appendEvents = alignWith $ mergeThese mappend

1262−

1263−-- | Alias for 'headE'

1264−{-# DEPRECATED onceE "Use 'headE' instead" #-}

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

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'. " #-}

1494+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1495+switchPromptly = switchHoldPromptly

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'. " #-}

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

1498+switchPromptOnly = switchHoldPromptOnly

src/Reflex/Collection.hs+157−60

@@ -1,22 +1,23 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE RankNTypes #-}

46{-# LANGUAGE RecursiveDo #-}

57{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE FlexibleInstances #-}

98{-# LANGUAGE TypeFamilies #-}

109{-# LANGUAGE UndecidableInstances #-}

1110#ifdef USE_REFLEX_OPTIMIZER

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

1312#endif

13+-- |

14+-- Module:

15+-- Reflex.Collection

1416module Reflex.Collection

15− (

17+ (

1618 -- * Widgets on Collections

1719 listHoldWithKey

1820 , listWithKey

19− , listWithKey'

2021 , listWithKeyShallowDiff

2122 , listViewWithKey

2223 , selectViewListWithKey

@@ -26,96 +27,192 @@ module Reflex.Collection

2627 , simpleList

2728 ) where

2829

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

30+import Control.Monad.Identity

3031import Data.Align

32+import Data.Functor.Misc

3133import Data.Map (Map)

3234import qualified Data.Map as Map

33−import Data.Functor.Misc

3435import Data.Map.Misc

3536import Data.These

3637

3738import Reflex.Class

39+import Reflex.Adjustable.Class

3840import Reflex.Dynamic

3941import Reflex.PostBuild.Class

4042

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

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

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

4253listHoldWithKey m0 m' f = do

4354 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

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

55+ dm' = fmap

56+ (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey

57+ (\k v -> ComposeMaybe $ fmap (f k) v)

58+ )

59+ m'

4560 (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

4761

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

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

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+

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

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

5074listWithKey vals mkChild = do

5175 postBuild <- getPostBuild

5276 let childValChangedSelector = fanMap $ updated vals

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

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

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

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

57− This _ -> Just Nothing

58− These _ _ -> Nothing

59− That new -> Just $ Just new

77+

78+ -- We keep track of changes to children values in the mkChild

79+ -- function we pass to listHoldWithKey The other changes we need

80+ -- to keep track of are child insertions and

81+ -- deletions. diffOnlyKeyChanges keeps track of insertions and

82+ -- deletions but ignores value changes, since they're already

83+ -- accounted for.

84+ diffOnlyKeyChanges olds news =

85+ flip Map.mapMaybe (align olds news) $ \case

86+ This _ -> Just Nothing

87+ These _ _ -> Nothing

88+ That new -> Just $ Just new

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

6190 let changeVals :: Event t (Map k (Maybe v))

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

63− [ updated vals

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

65− ]

91+ changeVals =

92+ attachWith diffOnlyKeyChanges (current sentVals) $ leftmost

93+ [ updated vals

94+

95+ -- TODO: This should probably be added to the

96+ -- attachWith, not to the updated; if we were using

97+ -- diffMap instead of diffMapNoEq, I think it might not

98+ -- work

99+ , tag (current vals) postBuild

100+ ]

66101 listHoldWithKey Map.empty changeVals $ \k v ->

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

68103

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)" #-}

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

71−listWithKey' = listWithKeyShallowDiff

72−

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.

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

104+-- | Display the given map of items (in key order) using the builder

105+-- function provided, and update it with the given event. 'Nothing'

106+-- update entries will delete the corresponding children, and 'Just'

107+-- entries will create them if they do not exist or send an update

108+-- event to them if they do.

109+listWithKeyShallowDiff

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

75115listWithKeyShallowDiff initialVals valsChanged mkChild = do

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

77117 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged

78118 let relevantPatch patch _ = case patch of

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

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

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

82− mkChild k v $ select childValChangedSelector $ Const2 k

83−

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

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

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

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

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

89−

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

119+

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+

125+ -- We don't want to let spurious re-creations of items through

126+ Just _ -> Nothing

127+ listHoldWithKey

128+ initialVals

129+ (attachWith (flip (Map.differenceWith relevantPatch))

130+ (current sentVals)

131+ valsChanged

132+ )

133+ $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k

134+

135+--TODO: Something better than Dynamic t (Map k v) - we want something

136+--where the Events carry diffs, not the whole value

137+-- | Create a dynamically-changing set of Event-valued widgets. This

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

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 =

148+ switch . fmap mergeMap <$> listViewWithKey' vals mkChild

149+

150+listViewWithKey'

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

91155listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

92156

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

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

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

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

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

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

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

161+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

162+ => Dynamic t k

163+ -- ^ Current selection key

164+ -> Dynamic t (Map k v)

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

168+ -- and Dynamic Bool indicating if this widget is currently selected

169+ -> m (Event t (k, a))

170+ -- ^ Event that fires when any child's return Event fires. Contains

171+ -- key of an arbitrary firing widget.

99172selectViewListWithKey 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

101175 selectChild <- listWithKey vals $ \k v -> do

102176 let selected = demuxed selectionDemux k

103177 selectSelf <- mkChild k v selected

104178 return $ fmap ((,) k) selectSelf

105179 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

106180

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

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

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

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

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

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

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

185+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

186+ => Dynamic t k

187+ -- ^ Current selection key

188+ -> Dynamic t (Map k v)

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

192+ -- and Dynamic Bool indicating if this widget is currently selected

193+ -> m (Event t k)

194+ -- ^ Event that fires when any child's return Event fires. Contains

195+ -- key of an arbitrary firing widget.

196+selectViewListWithKey_ selection vals mkChild =

197+ fmap fst <$> selectViewListWithKey selection vals mkChild

113198

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

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

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

199+-- | Create a dynamically-changing set of widgets from a Dynamic

200+-- key/value map. Unlike the 'withKey' variants, the child widgets

201+-- are insensitive to which key they're associated with.

202+list

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

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

118208

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

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

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

210+simpleList

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 =

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

1717#ifdef USE_REFLEX_OPTIMIZER

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

1919#endif

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

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

20+-- |

21+-- Module:

22+-- Reflex.Dynamic

23+-- Description:

24+-- This module contains various functions for working with 'Dynamic' values.

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

2226module Reflex.Dynamic

2327 ( -- * Basics

2428 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

3034 , constDyn

3135 , count

3236 , toggle

37+ , switchDyn

3338 , switchPromptlyDyn

3439 , tagPromptlyDyn

3540 , attachPromptlyDyn

@@ -58,28 +63,8 @@ module Reflex.Dynamic

5863 , Demux

5964 , demux

6065 , demuxed

61− -- Unsafe

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

66+ -- * Miscellaneous

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

8368 , HList (..)

8469 , FHList (..)

8570 , collectDynPure

@@ -88,12 +73,13 @@ module Reflex.Dynamic

8873 , AllAreFunctors (..)

8974 , HListPtr (..)

9075 , distributeFHListOverDynPure

76+ -- * Unsafe

77+ , unsafeDynamic

9178 ) where

9279

9380import Data.Functor.Misc

9481import Reflex.Class

9582

96−import Control.Applicative ((<*>))

9783import Control.Monad

9884import Control.Monad.Fix

9985import Control.Monad.Identity

@@ -105,7 +91,7 @@ import Data.Functor.Compose (Compose (Compose), getCompose)

10591import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

10692import Data.Map (Map)

10793import Data.Maybe (isJust)

108−import Data.Monoid

94+import Data.Monoid ((<>))

10995import Data.These

11096import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), Proxy (Proxy), SListI, SOP (SOP), from, hcmap, hmap, to, unSOP)

11197import Generics.SOP.Distribute (distributeI_NP)

@@ -132,7 +118,7 @@ holdUniqDyn = holdUniqDynBy (==)

132118holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

133119holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

134120

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/@)

136122improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))

137123improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

138124

@@ -176,7 +162,7 @@ foldDynMaybe = accumMaybeDyn . flip

176162foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)

177163foldDynMaybeM = accumMaybeMDyn . flip

178164

179−-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.

165+-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'.

180166count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

181167count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

182168

@@ -185,10 +171,25 @@ count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

185171toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

186172toggle = foldDyn (const not)

187173

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+

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

190187-- 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.

192193switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

193194switchPromptlyDyn de =

194195 let eLag = switch $ current de

@@ -222,10 +223,10 @@ distributeListOverDynPure =

222223-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

223224-- with the current values of the 'Dynamic's in a map.

224225joinDynThroughMap :: 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

226227

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

229230-- provided string. This should /only/ be used for debugging.

230231--

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

235236

236237-- | Print the result of applying the provided function to the value

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

239240-- debugging.

240241--

241242-- Note: Just like Debug.Trace.trace, the value will only be shown if something

@@ -251,36 +252,35 @@ traceDynWith f d =

251252-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

252253-- each time the 'Event' occurs.

253254--

254−-- 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−-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value

255+-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing

256+-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@

257+-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value

257258-- will be used, since the 'Behavior' won't be updated until the end of the frame.

258259-- 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−-- cyclic data flows, generally `tag (current d) e` is preferred.

260+-- the input 'Dynamic', because that would mean its value depends on itself. __When creating__

261+-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__

261262tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

262263tagPromptlyDyn = attachPromptlyDynWith const

263264

264265-- | Attach the current value of the 'Dynamic' to the value of the

265266-- 'Event' each time it occurs.

266267--

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.

268269attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

269270attachPromptlyDyn = attachPromptlyDynWith (,)

270271

271272-- | Combine the current value of the 'Dynamic' with the value of the

272273-- 'Event' each time it occurs.

273274--

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.

275276attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

276277attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

277278

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

279280-- current value of the 'Dynamic' value and possibly filtering if the combining

280281-- function returns 'Nothing'.

281282--

282−-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f

283−-- (current d)`. See 'tagPromptlyDyn' for details.

283+-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details.

284284attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

285285attachPromptlyDynWithMaybe f d e =

286286 let e' = attach (current d) e

@@ -289,8 +289,8 @@ attachPromptlyDynWithMaybe f d e =

289289 These (_, b) a -> f a b -- Both events are firing, so use the newer value

290290 That _ -> Nothing -- The tagging event isn't firing, so don't fire

291291

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

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

294294-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor

295295-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track

296296-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the

@@ -312,27 +312,6 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum

312312 LeftTag :=> Compose a -> Left $ coerceDynamic a

313313 RightTag :=> Compose b -> Right $ coerceDynamic b

314314

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−

336315-- | Use factorDyn and generics-sop to turn a Dynamic of a type into a factored

337316-- Dynamic of a type with Dynamic fields. For example:

338317--

@@ -341,7 +320,6 @@ factorDyn d = do

341320--

342321-- > eitherDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))

343322-- > eitherDyn = factorDynGeneric

344−

345323factorDynGeneric :: forall t m a b. (Reflex t, MonadFix m, MonadHold t m

346324 , Generic a, Generic b

347325 , (Code b) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code a))

@@ -356,6 +334,20 @@ factorDynGeneric da = do

356334 result = to . SOP <$> nsnpDyn''

357335 return result

358336

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

359351--------------------------------------------------------------------------------

360352-- Demux

361353--------------------------------------------------------------------------------

@@ -369,7 +361,7 @@ factorDynGeneric da = do

369361--

370362-- > demuxed (demux d) k === fmap (== k) d

371363--

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

373365-- /O(log(n))/, rather than /O(n)/ for fmap.

374366data Demux t k = Demux { demuxValue :: Behavior t k

375367 , demuxSelector :: EventSelector t (Const2 k Bool)

@@ -447,21 +439,12 @@ data FHList f l where

447439 FHCons :: f e -> FHList f l -> FHList f (e ': l)

448440

449441instance 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

456442 HHeadPtr `geq` HHeadPtr = Just Refl

457443 HHeadPtr `geq` HTailPtr _ = Nothing

458444 HTailPtr _ `geq` HHeadPtr = Nothing

459445 HTailPtr a `geq` HTailPtr b = a `geq` b

460446

461447instance 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

465448 HHeadPtr `gcompare` HHeadPtr = GEQ

466449 HHeadPtr `gcompare` HTailPtr _ = GLT

467450 HTailPtr _ `gcompare` HHeadPtr = GGT

@@ -587,134 +570,3 @@ instance IsHList (a, b, c, d, e, f) where

587570#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800

588571 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139

589572#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

1313 ( qDynPure

1414 , unqDyn

1515 , mkDynPure

16− -- * Deprecated functions

17− , qDyn

18− , mkDyn

1916 ) where

2017

2118import Generics.SOP (I (..), NP (..))

@@ -24,7 +21,7 @@ import Reflex.Dynamic.CollectDynGeneric (collectDynNP)

2421import Control.Monad.State

2522import Data.Data

2623import Data.Generics

27−import Data.Monoid

24+import Data.Monoid ((<>))

2825import qualified Language.Haskell.Exts as Hs

2926import qualified Language.Haskell.Meta.Syntax.Translate as Hs

3027import Language.Haskell.TH

@@ -52,7 +49,6 @@ qDynPure qe = do

5249 param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs

5350 [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |]

5451

55−

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

5753-- 'qDyn' quotation.

5854unqDyn :: Q Exp -> Q Exp

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

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

110106 | modName == modName' && occName == occName' = 'unqMarker

111107 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

171module Reflex.DynamicWriter

18− ( MonadDynamicWriter (..)

19− , DynamicWriterT (..)

20− , runDynamicWriterT

21− , withDynamicWriterT

2+ {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-}

3+ ( module X

224 ) where

235

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

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_

6+import Reflex.DynamicWriter.Base as X

7+import Reflex.DynamicWriter.Class as X

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

171module Reflex.EventWriter

18− ( EventWriterT (..)

19− , runEventWriterT

20− , EventWriter (..)

21− , runWithReplaceEventWriterTWith

22− , sequenceDMapWithAdjustEventWriterTWith

23− , withEventWriterT

2+ {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}

3+ ( module X

244 ) where

255

26−import Reflex.Class

27−import Reflex.Host.Class

28−import Reflex.PerformEvent.Class

29−import Reflex.PostBuild.Class

30−import Reflex.Query.Class

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

6+import Reflex.EventWriter.Base as X

7+import Reflex.EventWriter.Class as X

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

55{-# LANGUAGE ForeignFunctionInterface #-}

66{-# LANGUAGE JavaScriptFFI #-}

77#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.

821module Reflex.FastWeak

922 ( FastWeakTicket

1023 , FastWeak

@@ -35,29 +48,57 @@ import System.Mem.Weak

3548

3649

3750#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@.

3856newtype FastWeakTicket a = FastWeakTicket JSVal

3957

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@.

4067newtype FastWeak a = FastWeak JSVal

4168

4269-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

4370data Val a = Val { unVal :: a }

4471

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@

4673unsafeFromRawJSVal :: JSVal -> a

4774unsafeFromRawJSVal v = unVal (unsafeCoerce v)

4875

76+-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object.

4977unsafeToRawJSVal :: a -> JSVal

5078unsafeToRawJSVal v = unsafeCoerce (Val v)

5179#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.

5283data FastWeakTicket a = FastWeakTicket

5384 { _fastWeakTicket_val :: !a

5485 , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)

5586 }

5687

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

5796type FastWeak a = Weak a

5897#endif

5998

60−-- This needs to be in IO so we know that we've relinquished the ticket

99+-- | Return the @a@ kept alive by the given 'FastWeakTicket'.

100+--

101+-- This needs to be in IO so we know that we've relinquished the ticket.

61102getFastWeakTicketValue :: FastWeakTicket a -> IO a

62103#ifdef GHCJS_FAST_WEAK

63104getFastWeakTicketValue t = do

@@ -69,6 +110,8 @@ foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a

69110getFastWeakTicketValue = return . _fastWeakTicket_val

70111#endif

71112

113+-- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected,

114+-- or @Nothing@ if it has been collected.

72115getFastWeakValue :: FastWeak a -> IO (Maybe a)

73116#ifdef GHCJS_FAST_WEAK

74117getFastWeakValue w = do

@@ -84,6 +127,9 @@ foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.v

84127getFastWeakValue = deRefWeak

85128#endif

86129

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.

87133getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

88134#ifdef GHCJS_FAST_WEAK

89135getFastWeakTicket w = do

@@ -103,8 +149,11 @@ getFastWeakTicket w = do

103149 }

104150#endif

105151

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

107154mkFastWeakTicket :: 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

108157#ifdef GHCJS_FAST_WEAK

109158mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)

110159

@@ -119,11 +168,16 @@ mkFastWeakTicket v = do

119168 }

120169#endif

121170

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)

122175-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value

123176#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'

125180#else

126−getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

127181getFastWeakTicketWeak = return . _fastWeakTicket_weak

128182#endif

129183

@@ -133,7 +187,6 @@ emptyFastWeak = unsafeCoerce w

133187 where w :: FastWeak Any

134188#ifdef GHCJS_FAST_WEAK

135189 w = js_emptyWeak

136−foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any

137190#else

138191 w = unsafePerformIO $ do

139192 w' <- mkWeakPtr undefined Nothing

@@ -141,3 +194,7 @@ foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: Fa

141194 return w'

142195#endif

143196{-# 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−-- | This module defines the FunctorMaybe class, which extends Functors with the

2−-- ability to delete values.

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE StandaloneDeriving #-}

5+-- |

6+-- Module:

7+-- Reflex.FunctorMaybe

8+-- Description:

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

10+-- ability to delete values.

311module Reflex.FunctorMaybe

412 ( FunctorMaybe (..)

513 ) where

614

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

821

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

1023

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

12−-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the

13−-- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@,

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@

25+-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@.

26+{-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-}

2327class FunctorMaybe f where

2428 -- | Combined mapping and filtering function.

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

2630

27−-- | @fmapMaybe = (=<<)

2831instance FunctorMaybe Maybe where

29− fmapMaybe = (=<<)

32+ fmapMaybe = mapMaybe

33+

34+#if MIN_VERSION_base(4,9,0)

35+deriving instance FunctorMaybe Option

36+#endif

3037

31−-- | @fmapMaybe f = catMaybes . fmap f@

3238instance 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

3030

3131import Reflex.Class

3232

33−import Control.Applicative

34−import Control.Monad

3533import Control.Monad.Fix

3634import Control.Monad.Identity

3735import Control.Monad.Ref

3836import Control.Monad.Trans

39−import Control.Monad.Trans.Cont (ContT ())

40−import Control.Monad.Trans.Except (ExceptT ())

41−import Control.Monad.Trans.Reader (ReaderT ())

42−import Control.Monad.Trans.RWS (RWST ())

43−import Control.Monad.Trans.State (StateT ())

37+import Control.Monad.Trans.Cont (ContT)

38+import Control.Monad.Trans.Except (ExceptT)

39+import Control.Monad.Trans.Reader (ReaderT)

40+import Control.Monad.Trans.RWS (RWST)

41+import Control.Monad.Trans.State (StateT)

4442import qualified Control.Monad.Trans.State.Strict as Strict

45−import Control.Monad.Trans.Writer (WriterT ())

43+import Control.Monad.Trans.Writer (WriterT)

4644import Data.Dependent.Sum (DSum (..))

4745import 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

6546

6647-- | Framework implementation support class for the reflex implementation

6748-- represented by @t@.

src/Reflex/Network.hs+14−9

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DefaultSignatures #-}

32{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE FunctionalDependencies #-}

53#ifdef USE_REFLEX_OPTIMIZER

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

75#endif

6+-- |

7+-- Module:

8+-- Reflex.Network

9+-- Description:

10+-- This module provides combinators for building FRP graphs/networks and modifying them dynamically.

811module Reflex.Network

912 ( networkView

1013 , networkHold

@@ -12,29 +15,31 @@ module Reflex.Network

1215 ) where

1316

1417import Reflex.Class

18+import Reflex.Adjustable.Class

1519import Reflex.NotReady.Class

1620import Reflex.PostBuild.Class

1721

18−-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.

19−-- The returned Event of network results occurs when the Dynamic does.

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').

21−networkView :: (Reflex t, NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

22+-- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates.

23+-- The returned Event of network results fires when the 'Dynamic' updates.

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').

26+networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

2227networkView child = do

2328 postBuild <- getPostBuild

2429 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

2530 snd <$> runWithReplace notReady newChild

2631

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.

2833-- The returned Dynamic of network results occurs when the Event does.

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

3136networkHold child0 newChild = do

3237 (result0, newResult) <- runWithReplace child0 newChild

3338 holdDyn result0 newResult

3439

3540-- | Render a placeholder network to be shown while another network is not yet

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

3843untilReady a b = do

3944 postBuild <- getPostBuild

4045 runWithReplace a $ b <$ postBuild

src/Reflex/NotReady/Class.hs+17−6

@@ -1,9 +1,10 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DefaultSignatures #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

57{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE FlexibleInstances #-}

78{-# LANGUAGE UndecidableInstances #-}

89#ifdef USE_REFLEX_OPTIMIZER

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

@@ -12,17 +13,19 @@ module Reflex.NotReady.Class

1213 ( NotReady(..)

1314 ) where

1415

15−import Control.Monad.Trans

1616import Control.Monad.Reader (ReaderT)

17+import Control.Monad.Trans

18+import Control.Monad.Trans.Writer (WriterT)

1719

20+import Reflex.BehaviorWriter.Base (BehaviorWriterT)

1821import Reflex.Class

22+import Reflex.DynamicWriter.Base (DynamicWriterT)

23+import Reflex.EventWriter.Base (EventWriterT)

1924import Reflex.Host.Class

25+import Reflex.PerformEvent.Base (PerformEventT (..))

2026import Reflex.PostBuild.Base (PostBuildT)

21−import Reflex.EventWriter (EventWriterT)

22−import Reflex.DynamicWriter (DynamicWriterT)

2327import Reflex.Query.Base (QueryT)

2428import Reflex.Requester.Base (RequesterT)

25−import Reflex.PerformEvent.Base (PerformEventT(..))

2629import Reflex.TriggerEvent.Base (TriggerEventT)

2730

2831class Monad m => NotReady t m | m -> t where

@@ -38,6 +41,10 @@ instance NotReady t m => NotReady t (ReaderT r m) where

3841 notReadyUntil = lift . notReadyUntil

3942 notReady = lift notReady

4043

44+instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where

45+ notReadyUntil = lift . notReadyUntil

46+ notReady = lift notReady

47+

4148instance NotReady t m => NotReady t (PostBuildT t m) where

4249 notReadyUntil = lift . notReadyUntil

4350 notReady = lift notReady

@@ -50,6 +57,10 @@ instance NotReady t m => NotReady t (DynamicWriterT t w m) where

5057 notReadyUntil = lift . notReadyUntil

5158 notReady = lift notReady

5259

60+instance NotReady t m => NotReady t (BehaviorWriterT t w m) where

61+ notReadyUntil = lift . notReadyUntil

62+ notReady = lift notReady

63+

5364instance NotReady t m => NotReady t (QueryT t q m) where

5465 notReadyUntil = lift . notReadyUntil

5566 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.

51{-# LANGUAGE CPP #-}

62{-# LANGUAGE LambdaCase #-}

73{-# 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.

812module Reflex.Optimizer

913 ( plugin

1014 ) where

@@ -16,6 +20,11 @@ import Control.Arrow

1620import CoreMonad

1721import Data.String

1822import GhcPlugins

23+

24+#if MIN_VERSION_base(4,9,0)

25+import Prelude hiding ((<>))

26+#endif

27+

1928#endif

2029

2130#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.

31{-# 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.

48module Reflex.Patch

59 ( module Reflex.Patch

610 , module X

@@ -8,15 +12,18 @@ module Reflex.Patch

812

913import Reflex.Patch.Class as X

1014import Reflex.Patch.DMap as X hiding (getDeletions)

11−import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)

12−import Reflex.Patch.Map as X

13−import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElementsMap, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

15+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,

16+ patchDMapWithMoveToPatchMapWithMoveWith,

17+ traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,

18+ unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)

1419import 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)

1625import Data.Semigroup (Semigroup (..), (<>))

1726

18−---- Patches based on commutative groups

19−

2027-- | A 'Group' is a 'Monoid' where every element has an inverse.

2128class (Semigroup q, Monoid q) => Group q where

2229 negateG :: q -> q

@@ -32,3 +39,8 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

3239instance Additive p => Patch (AdditivePatch p) where

3340 type PatchTarget (AdditivePatch p) = p

3441 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

55import Control.Monad.Identity

66import Data.Maybe

7+import Data.Semigroup (Semigroup(..))

89-- | 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@.

913class Patch p where

1014 type PatchTarget p :: *

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

2024instance Patch (Identity a) where

2125 type PatchTarget (Identity a) = a

2226 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 @@

55{-# LANGUAGE ScopedTypeVariables #-}

66{-# LANGUAGE StandaloneDeriving #-}

77{-# LANGUAGE TypeFamilies #-}

8+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

89module Reflex.Patch.DMap where

910

1011import Reflex.Patch.Class

@@ -14,20 +15,22 @@ import Reflex.Patch.Map

1415import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

1516import qualified Data.Dependent.Map as DMap

1617import Data.Functor.Constant

17−import qualified Data.IntMap as IntMap

1818import Data.Functor.Misc

19+import qualified Data.IntMap as IntMap

1920import qualified Data.Map as Map

2021import Data.Semigroup (Semigroup (..))

2122import Data.Some (Some)

2223

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

24−-- deleted.

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

25+-- Insertions are represented as @'ComposeMaybe' (Just value)@,

26+-- while deletions are represented as @'ComposeMaybe' Nothing@.

2527newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }

2628

2729deriving instance GCompare k => Semigroup (PatchDMap k v)

2830

2931deriving instance GCompare k => Monoid (PatchDMap k v)

3032

33+-- | Apply the insertions or deletions to a given 'DMap'.

3134instance GCompare k => Patch (PatchDMap k v) where

3235 type PatchTarget (PatchDMap k v) = DMap k v

3336 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

3740 Nothing -> Just $ Constant ()

3841 Just _ -> Nothing

3942

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'@.

4045mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'

4146mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p

4247

43−traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

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'@.

50+traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')

4451traversePatchDMap f = traversePatchDMapWithKey $ const f

4552

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'@.

4655traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

4756traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p

4857

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.

4960weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'

5061weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p

5162

52−patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'

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'@.

65+patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'

5366patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p

5467

55−const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f

68+-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.

69+const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'

5670const2PatchDMapWith 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')

5872 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

5973

74+-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.

6075const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f

6176const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p

6277 where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)

6378 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

6479

65−-- | Get the values that will be deleted if the given patch is applied to the

66−-- given 'DMap'. Includes values that will be replaced.

80+-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.

6781getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'

6882getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p

src/Reflex/Patch/DMapWithMove.hs+136−53

@@ -10,6 +10,9 @@

1010{-# LANGUAGE ScopedTypeVariables #-}

1111{-# LANGUAGE TypeFamilies #-}

1212{-# 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.

1316module Reflex.Patch.DMapWithMove where

1417

1518import Reflex.Patch.Class

@@ -23,6 +26,7 @@ import Data.Functor.Constant

2326import Data.Functor.Misc

2427import Data.Functor.Product

2528import Data.GADT.Compare (GEq (..))

29+import Data.GADT.Show (GShow, gshow)

2630import qualified Data.Map as Map

2731import Data.Maybe

2832import Data.Semigroup (Semigroup (..), (<>))

@@ -30,65 +34,91 @@ import Data.Some (Some)

3034import qualified Data.Some as Some

3135import Data.These

3236

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

4044newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

41−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

42− deriving (Show)

43−#endif

4445

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.

4548data NodeInfo k v a = NodeInfo

4649 { _nodeInfo_from :: !(From k v a)

50+ -- ^Change applying to the current key, be it an insert, move, or delete.

4751 , _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'.

4853 }

4954 deriving (Show)

5055

51−#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

52−instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (NodeInfo k v) where

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−

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

57+-- key (@From_Delete@), or moving a key (@From_Move@).

5958data From (k :: a -> *) (v :: a -> *) :: a -> * where

59+ -- |Insert a new or update an existing key with the given value @v a@

6060 From_Insert :: v a -> From k v a

61+ -- |Delete the existing key

6162 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@.

6265 From_Move :: !(k a) -> From k v a

6366 deriving (Show, Read, Eq, Ord)

6467

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.

6570type To = ComposeMaybe

6671

67−validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool

68−validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst

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

72+-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.

73+validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool

74+validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

7675

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.

77108instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where

78109 PatchDMapWithMove a == PatchDMapWithMove b = a == b

79110

111+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9

80112data Pair1 f g a = Pair1 (f a) (g a)

81113

82−instance GCompare k => Semigroup (PatchDMapWithMove k v) where

83− (<>) = mappend

84−

114+-- |Helper data structure used for composing patches using the monoid instance.

85115data Fixup k v a

86116 = Fixup_Delete

87117 | Fixup_Update (These (From k v a) (To k a))

88118

89−instance GCompare k => Monoid (PatchDMapWithMove k v) where

90− mempty = PatchDMapWithMove mempty

91− PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m

119+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

120+instance GCompare k => Semigroup (PatchDMapWithMove k v) where

121+ PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

92122 where

93123 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb

94124 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

122152 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

123153 }

124154 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups

125−

126−getHere :: These a b -> Maybe a

127−getHere = \case

128− This a -> Just a

129− These a _ -> Just a

130− That _ -> Nothing

131−

132−getThere :: These a b -> Maybe b

133−getThere = \case

134− This _ -> Nothing

135− These _ b -> Just b

136− That b -> Just b

155+ getHere :: These a b -> Maybe a

156+ getHere = \case

157+ This a -> Just a

158+ These a _ -> Just a

159+ That _ -> Nothing

160+ getThere :: These a b -> Maybe b

161+ getThere = \case

162+ This _ -> Nothing

163+ These _ 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 = (<>)

137170

138171{-

139172mappendPatchDMapWithMoveSlow :: 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

157190 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore

158191-}

159192

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+-- @

160203moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

161204moveDMapKey src dst = case src `geq` dst of

162205 Nothing -> PatchDMapWithMove $ DMap.fromList

@@ -165,6 +208,24 @@ moveDMapKey src dst = case src `geq` dst of

165208 ]

166209 Just _ -> mempty

167210

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

168229deleteDMapKey :: k a -> PatchDMapWithMove k v

169230deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing

170231

@@ -192,14 +253,25 @@ dst (PatchDMapWithMove x _) = x

192253src (PatchDMapWithMove _ x) = x

193254-}

194255

256+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.

195257unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

196258unPatchDMapWithMove (PatchDMapWithMove p) = p

197259

198−-- | Warning: when using this function, you must ensure that the invariants of

199−-- 'PatchDMapWithMove' are preserved; they will not be checked.

260+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.

261+--

262+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.

200263unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

201264unsafePatchDMapWithMove = PatchDMapWithMove

202265

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'@.

203275mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'

204276mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

205277 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p

@@ -209,9 +281,11 @@ mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

209281 From_Delete -> From_Delete

210282 From_Move k -> From_Move k

211283

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')@.

212285traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

213286traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

214287

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')@.

215289traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

216290traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

217291 where g :: forall a. k a -> From k v a -> m (From k v' a)

@@ -220,12 +294,16 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$>

220294 From_Delete -> pure From_Delete

221295 From_Move fromKey -> pure $ From_Move fromKey

222296

297+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.

223298nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

224299nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

225300

301+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.

226302nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

227303nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

228304

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.

229307weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

230308weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

231309 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'

@@ -237,9 +315,11 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD

237315 , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)

238316 }

239317

240−patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'

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.

320+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'

241321patchDMapWithMoveToPatchMapWithMoveWith 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'

243323 g ni = MapWithMove.NodeInfo

244324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

245325 From_Insert v -> MapWithMove.From_Insert $ f v

@@ -248,9 +328,12 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo

248328 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

249329 }

250330

251−const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f

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'

334+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'

252335const2PatchDMapWithMoveWith 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')

254337 g (k, ni) = Const2 k :=> NodeInfo

255338 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

256339 MapWithMove.From_Insert v -> From_Insert $ f v

@@ -259,6 +342,7 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr

259342 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

260343 }

261344

345+-- | Apply the insertions, deletions, and moves to a given 'DMap'.

262346instance GCompare k => Patch (PatchDMapWithMove k v) where

263347 type PatchTarget (PatchDMapWithMove k v) = DMap k v

264348 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

274358 From_Delete -> Just $ Constant ()

275359 _ -> Nothing

276360

277−-- | Get the values that will be deleted or moved if the given patch is applied

278−-- to the given 'DMap'.

361+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.

279362getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

280363getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

281364 where f _ v ni = Pair v $ _nodeInfo_to ni

src/Reflex/Patch/IntMap.hs+20−3

@@ -1,20 +1,25 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

32{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveFunctor #-}

44{-# LANGUAGE DeriveTraversable #-}

55{-# LANGUAGE GeneralizedNewtypeDeriving #-}

66{-# LANGUAGE TypeFamilies #-}

7+-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for

8+-- insert/update or delete of associations.

79module Reflex.Patch.IntMap where

810

9−import Prelude hiding (lookup)

1011import Data.IntMap.Strict (IntMap)

1112import qualified Data.IntMap.Strict as IntMap

1213import Data.Maybe

1314import Data.Semigroup

1415import Reflex.Patch.Class

1516

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.

1620newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

1721

22+-- | Apply the insertions or deletions to a given 'IntMap'.

1823instance Patch (PatchIntMap a) where

1924 type PatchTarget (PatchIntMap a) = IntMap a

2025 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

@@ -37,14 +42,26 @@ instance Semigroup (PatchIntMap v) where

3742 GT -> x

3843#endif

3944

40−traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)

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)@.

52+traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)

4153traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

4254

55+-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.

4356patchIntMapNewElements :: PatchIntMap a -> [a]

4457patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

4558

59+-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all

60+-- the inserts/updates in the given patch.

4661patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

4762patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

4863

64+-- | Subset the given @'IntMap' a@ to contain only the keys that would be

65+-- deleted by the given @'PatchIntMap' a@.

4966getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

5067getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Reflex/Patch/Map.hs+2−3

@@ -7,10 +7,10 @@ module Reflex.Patch.Map where

88import Reflex.Patch.Class

10−import Data.Semigroup

1110import Data.Map (Map)

1211import qualified Data.Map as Map

1312import Data.Maybe

13+import Data.Semigroup

1414

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

1616-- deleted. Insertions are represented as values wrapped in 'Just', while

@@ -18,8 +18,7 @@ import Data.Maybe

1818newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

1919 deriving (Show, Read, Eq, Ord)

2020

21−-- | Applying a 'PatchMap' will update the 'Map' by performing the insertions

22−-- and deletions specified

21+-- | Apply the insertions or deletions to a given 'Map'.

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

2423 type PatchTarget (PatchMap k v) = Map k v

2524 {-# INLINABLE apply #-}

src/Reflex/Patch/MapWithMove.hs+134−20

@@ -3,6 +3,7 @@

33{-# LANGUAGE DeriveTraversable #-}

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE PatternGuards #-}

67{-# LANGUAGE ScopedTypeVariables #-}

78{-# LANGUAGE TypeFamilies #-}

89-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

@@ -19,7 +20,9 @@ import Data.List

1920import Data.Map (Map)

2021import qualified Data.Map as Map

2122import Data.Maybe

23+import Data.Semigroup (Semigroup (..), (<>))

2224import qualified Data.Set as Set

25+import Data.These (These(..))

2326import Data.Tuple

2427

2528-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@

@@ -38,6 +41,18 @@ data NodeInfo k v = NodeInfo

3841 }

3942 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

4043

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+

4156-- | Create a 'PatchMapWithMove', validating it

4257patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)

4358patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

@@ -48,26 +63,62 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

4863 From_Move from -> Just (from, to)

4964 _ -> Nothing

5065

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+

5173-- | Extract the internal representation of the 'PatchMapWithMove'

5274unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

5375unPatchMapWithMove (PatchMapWithMove p) = p

5476

55−-- | Warning: when using this function, you must ensure that the invariants of

56−-- 'PatchMapWithMove' are preserved; they will not be checked.

57−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

58−unsafePatchMapWithMove = PatchMapWithMove

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

78+insertMapKey :: k -> v -> PatchMapWithMove k v

79+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

5980

60−-- | Describe how a key's new value should be produced

61−data From k v

62− = From_Insert v -- ^ Insert the given value here

63− | From_Delete -- ^ Delete the existing value, if any, from here

64− | From_Move !k -- ^ Move the value here from the given key

65− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

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:

82+--

83+-- @

84+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

85+-- @

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+ ]

6694

67−-- | Describe where a key's old value will go. If this is 'Just', that means

68−-- the key's old value will be moved to the given other key; if it is 'Nothing',

69−-- that means it will be deleted.

70−type To = Maybe

95+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

96+--

97+-- @

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

71122

72123-- | Apply the insertions, deletions, and moves to a given 'Map'

73124instance Ord k => Patch (PatchMapWithMove k v) where

@@ -81,10 +132,11 @@ instance Ord k => Patch (PatchMapWithMove k v) where

81132 From_Delete -> Just ()

82133 _ -> Nothing

83134

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

85136patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

86137patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

87138

139+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.

88140patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

89141patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

90142 where f ni = case _nodeInfo_from ni of

@@ -110,11 +162,15 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW

110162-- will produce a 'Map' with the same values as the second 'Map' but with the

111163-- values sorted with the given ordering function.

112164patchThatChangesAndSortsMapWith :: 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

114− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

115− newList = Map.toList newByIndexUnsorted

165+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

166+ where newList = Map.toList newByIndexUnsorted

116167 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

118174 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

119175 let f k v = do

120176 remainingValues <- get

@@ -129,7 +185,7 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch

129185 putRemainingKeys $ Set.delete k fromKs

130186 return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

131187 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

133189 putRemainingKeys remainingKeys

134190 return $ NodeInfo (From_Move fromK) $ Just undefined

135191 Map.traverseWithKey f newByIndex

@@ -154,3 +210,61 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _

154210-- | Set the 'To' field of a 'NodeInfo'

155211nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

156212nodeInfoSetTo 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

2525 ) where

2626

2727import Reflex.Class

28+import Reflex.Adjustable.Class

2829import Reflex.Host.Class

2930import Reflex.PerformEvent.Class

3031import Reflex.Requester.Base

@@ -60,14 +61,14 @@ deriving instance ReflexHost t => Monad (PerformEventT t m)

6061deriving instance ReflexHost t => MonadFix (PerformEventT t m)

6162deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

6263deriving 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, Applicative m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)

64+deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)

65+deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)

6566

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

6768 type PrimState (PerformEventT t m) = PrimState (HostFrame t)

6869 primitive = PerformEventT . lift . primitive

6970

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

7172 type Performable (PerformEventT t m) = HostFrame t

7273 {-# INLINABLE performEvent_ #-}

7374 performEvent_ = PerformEventT . requesting_

src/Reflex/PostBuild/Base.hs+2−1

@@ -23,6 +23,7 @@ module Reflex.PostBuild.Base

2323 ) where

2424

2525import Reflex.Class

26+import Reflex.Adjustable.Class

2627import Reflex.Host.Class

2728import Reflex.PerformEvent.Class

2829import Reflex.PostBuild.Class

@@ -151,7 +152,7 @@ mapIntMapWithAdjustImpl base f dm0 dm' = do

151152 rec (result0, result') <- base f' loweredDm0 loweredDm'

152153 cohortDone <- numberOccurrencesFrom_ 1 result'

153154 numberedDm' <- numberOccurrencesFrom 1 dm'

154− let postBuild' = fanInt $ fmapCheap (\n -> IntMap.singleton n ()) cohortDone

155+ let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone

155156 loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do

156157 return $ fmap ((,) (selectInt postBuild' n)) p

157158 return (result0, result')

src/Reflex/Profiled.hs+19−5

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

11{-# LANGUAGE EmptyDataDecls #-}

2+{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE FlexibleInstances #-}

34{-# LANGUAGE GeneralizedNewtypeDeriving #-}

45{-# LANGUAGE InstanceSigs #-}

@@ -7,10 +8,17 @@

78{-# LANGUAGE StandaloneDeriving #-}

89{-# LANGUAGE TypeFamilies #-}

910{-# 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.

1017module Reflex.Profiled where

1118

1219import Control.Lens hiding (children)

1320import Control.Monad

21+import Control.Monad.Exception

1422import Control.Monad.Fix

1523import Control.Monad.Primitive

1624import Control.Monad.Reader

@@ -18,21 +26,22 @@ import Control.Monad.Ref

1826import Control.Monad.State.Strict (StateT, execStateT, modify)

1927import Data.Coerce

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

21−import Data.List

2229import Data.FastMutableIntMap

2330import Data.IORef

31+import Data.List

2432import Data.Map (Map)

2533import qualified Data.Map.Strict as Map

26−import Data.Monoid

34+import Data.Monoid ((<>))

2735import Data.Ord

36+import qualified Data.Semigroup as S

2837import Data.Type.Coercion

2938import Foreign.Ptr

3039import GHC.Foreign

3140import GHC.IO.Encoding

3241import GHC.Stack

3342import Reflex.Class

34−import Reflex.PerformEvent.Class

3543import Reflex.Host.Class

44+import Reflex.PerformEvent.Class

3645

3746import System.IO.Unsafe

3847import Unsafe.Coerce

@@ -50,9 +59,13 @@ data CostCentreTree = CostCentreTree

5059 }

5160 deriving (Show, Eq, Ord)

5261

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+

5366instance Monoid CostCentreTree where

5467 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.<>)

5669

5770getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]

5871getCostCentreStack = go []

@@ -95,7 +108,8 @@ writeProfilingData :: FilePath -> IO ()

95108writeProfilingData p = do

96109 writeFile p =<< formatCostCentreTree =<< getCostCentreTree

97110

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)

99113

100114profileEvent :: Reflex t => Event t a -> Event t a

101115profileEvent e = unsafePerformIO $ do

src/Reflex/Pure.hs+11−9

@@ -13,11 +13,13 @@

1313-- * MonadSample (Pure t) ((->) t)

1414-- * MonadHold (Pure t) ((->) t)

1515{-# OPTIONS_GHC -fno-warn-orphans #-}

16−

17−-- | 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

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

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

16+-- |

17+-- Module: Reflex.Pure

18+-- Description:

19+-- This module provides a pure implementation of Reflex, which is intended to

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

21+-- implementations of Reflex should produce the same results as this

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

2123module Reflex.Pure

2224 ( Pure

2325 , Behavior (..)

@@ -43,12 +45,12 @@ import Data.Type.Coercion

4345import Reflex.Class

4446

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

46−-- with the type @t@.

48+-- with the type @/t/@.

4749data Pure t

4850

49−-- | 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

51−-- exclusively to memoize functions of t, not for any of its other capabilities.

51+-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

52+-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

53+-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.

5254instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

5355

5456 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

src/Reflex/Query/Base.hs+73−15

@@ -2,11 +2,14 @@

22{-# LANGUAGE GeneralizedNewtypeDeriving #-}

33{-# LANGUAGE InstanceSigs #-}

44{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE LambdaCase #-}

56{-# LANGUAGE MultiParamTypeClasses #-}

67{-# LANGUAGE RankNTypes #-}

78{-# LANGUAGE ScopedTypeVariables #-}

89{-# LANGUAGE TypeFamilies #-}

910{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+

1013module Reflex.Query.Base

1114 ( QueryT (..)

1215 , runQueryT

@@ -19,6 +22,7 @@ module Reflex.Query.Base

1922import Control.Applicative (liftA2)

2023import Control.Monad.Exception

2124import Control.Monad.Fix

25+import Control.Monad.Primitive

2226import Control.Monad.Reader

2327import Control.Monad.Ref

2428import Control.Monad.State.Strict

@@ -28,26 +32,34 @@ import qualified Data.Dependent.Map as DMap

2832import Data.Foldable

2933import Data.Functor.Compose

3034import Data.Functor.Misc

35+import Data.IntMap (IntMap)

36+import qualified Data.IntMap as IntMap

3137import Data.Map (Map)

3238import qualified Data.Map as Map

33−import Data.Monoid

39+import Data.Monoid ((<>))

3440import qualified Data.Semigroup as S

3541import Data.Some (Some)

3642import qualified Data.Some as Some

3743import Data.These

3844

3945import 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

4150import Reflex.Host.Class

51+import qualified Reflex.Patch.MapWithMove as MapWithMove

4252import Reflex.PerformEvent.Class

4353import Reflex.PostBuild.Class

4454import Reflex.Query.Class

4555import Reflex.Requester.Class

4656import Reflex.TriggerEvent.Class

47−import qualified Reflex.Patch.MapWithMove as MapWithMove

4857

4958newtype 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)

5163

5264runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

5365runQueryT (QueryT a) qr = do

@@ -85,6 +97,52 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj

8597 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

8698 QueryT $ lift $ tellEvent patches

8799 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+

88146 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'))

89147 traverseDMapWithKeyWithAdjust f dm0 dm' = do

90148 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

129187 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

130188 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

131189 return (liftedResult0, liftedResult')

190+

132191 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'))

133192 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

134193 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

186245instance MonadTrans (QueryT t q) where

187246 lift = QueryT . lift . lift . lift

188247

248+instance PrimMonad m => PrimMonad (QueryT t q m) where

249+ type PrimState (QueryT t q m) = PrimState m

250+ primitive = lift . primitive

251+

189252instance PostBuild t m => PostBuild t (QueryT t q m) where

190253 getPostBuild = lift getPostBuild

191254

@@ -215,18 +278,11 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q

215278-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

216279instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where

217280 mempty = pure mempty

218− mappend = liftA2 mappend

281+ mappend = (<>)

219282

220283instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where

221284 (<>) = liftA2 (S.<>)

222285

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−

230286-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly

231287withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')

232288 => QueryMorphism q q'

@@ -252,7 +308,7 @@ dynWithQueryT f q = do

252308 return result

253309 where zipDynIncrementalWith g da ib =

254310 let eab = align (updated da) (updatedIncremental ib)

255− ec = flip push eab $ \o -> case o of

311+ ec = flip push eab $ \case

256312 This a -> do

257313 aOld <- sample $ current da

258314 b <- sample $ currentIncremental ib

@@ -273,8 +329,7 @@ instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (Qu

273329 askQueryResult = QueryT ask

274330 queryIncremental q = do

275331 tellQueryIncremental q

276− r <- askQueryResult

277− return $ zipDynWith crop (incrementalToDynamic q) r

332+ zipDynWith crop (incrementalToDynamic q) <$> askQueryResult

278333

279334instance Requester t m => Requester t (QueryT t q m) where

280335 type Request (QueryT t q m) = Request m

@@ -284,3 +339,6 @@ instance Requester t m => Requester t (QueryT t q m) where

284339

285340instance EventWriter t w m => EventWriter t w (QueryT t q m) where

286341 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

1515 , MonadQuery (..)

1616 , tellQueryDyn

1717 , queryDyn

18+ , mapQuery

19+ , mapQueryResult

1820 ) where

1921

22+import Control.Category (Category)

23+import qualified Control.Category as Cat

2024import Control.Monad.Reader

2125import Data.Bits

2226import Data.Data

2327import 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(..))

2531import Foreign.Storable

2632

2733import Reflex.Class

@@ -30,6 +36,10 @@ class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where

3036 type QueryResult a :: *

3137 crop :: a -> QueryResult a -> QueryResult a

3238

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+

3343-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type

3444-- and compatible with the query relationship when acting on the query result

3545data QueryMorphism q q' = QueryMorphism

@@ -37,6 +47,19 @@ data QueryMorphism q q' = QueryMorphism

3747 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q

3848 }

3949

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+

4063-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app

4164newtype SelectedCount = SelectedCount { unSelectedCount :: Int }

4265 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

7396queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

7497queryDyn q = do

7598 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 @@

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

22-- 'Requester'.

33{-# LANGUAGE AllowAmbiguousTypes #-}

4−{-# LANGUAGE BangPatterns #-}

54{-# LANGUAGE CPP #-}

65{-# LANGUAGE EmptyDataDecls #-}

76{-# LANGUAGE ExistentialQuantification #-}

@@ -22,17 +21,24 @@

2221module Reflex.Requester.Base

2322 ( RequesterT (..)

2423 , runRequesterT

24+ , withRequesterT

2525 , runWithReplaceRequesterTWith

2626 , traverseIntMapWithKeyWithAdjustRequesterTWith

2727 , traverseDMapWithKeyWithAdjustRequesterTWith

2828 , RequesterData

2929 , RequesterDataKey

3030 , traverseRequesterData

31+ , forRequesterData

3132 , requesterDataToList

3233 , singletonRequesterData

34+ , matchResponsesWithRequests

35+ , multiEntry

36+ , unMultiEntry

37+ , requesting'

3338 ) where

3439

3540import Reflex.Class

41+import Reflex.Adjustable.Class

3642import Reflex.Dynamic

3743import Reflex.Host.Class

3844import Reflex.PerformEvent.Class

@@ -43,6 +49,7 @@ import Reflex.TriggerEvent.Class

4349import Control.Applicative (liftA2)

4450import Control.Monad.Exception

4551import Control.Monad.Identity

52+import Control.Monad.Primitive

4653import Control.Monad.Reader

4754import Control.Monad.Ref

4855import Control.Monad.State.Strict

@@ -50,7 +57,6 @@ import Data.Bits

5057import Data.Coerce

5158import Data.Dependent.Map (DMap, DSum (..))

5259import qualified Data.Dependent.Map as DMap

53−import qualified Data.Some as Some

5460import Data.Functor.Compose

5561import Data.Functor.Misc

5662import Data.IntMap.Strict (IntMap)

@@ -58,11 +64,12 @@ import qualified Data.IntMap.Strict as IntMap

5864import Data.Map (Map)

5965import qualified Data.Map as Map

6066import Data.Monoid ((<>))

61−import Data.Unique.Tag

67+import Data.Proxy

6268import qualified Data.Semigroup as S

6369import Data.Some (Some)

70+import qualified Data.Some as Some

6471import Data.Type.Equality

65−import Data.Proxy

72+import Data.Unique.Tag

6673

6774import GHC.Exts (Any)

6875import Unsafe.Coerce

@@ -110,9 +117,9 @@ singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

110117singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

111118

112119tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

113−tagMapToList (TagMap m) = fmap f $ IntMap.toList m

120+tagMapToList (TagMap m) = f <$> IntMap.toList m

114121 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

116123

117124traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

118125traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

@@ -130,6 +137,10 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith

130137 MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

131138 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

132139

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+

133144data MyTagType :: * -> * where

134145 MyTagType_Single :: MyTagType (Single a)

135146 MyTagType_Multi :: MyTagType Multi

@@ -239,6 +250,10 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

239250deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

240251deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

241252

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+

242257-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

243258instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

244259 mempty = pure mempty

@@ -252,7 +267,6 @@ instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response

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

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

254269-- requests were issued.

255−

256270runRequesterT :: (Reflex t, Monad m)

257271 => RequesterT t request response m a

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

262276 coerceEvent responses

263277 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

264278

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+

265293instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

266294 type Request (RequesterT t request response m) = request

267295 type Response (RequesterT t request response m) = response

@@ -281,7 +309,7 @@ tagRequest req = do

281309 return t

282310

283311{-# 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))

285313responseFromTag (MyTagWrap t) = do

286314 responses :: EventSelectorInt t Any <- RequesterT ask

287315 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 (

316344 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

317345 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

318346

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

320348requesting' = responseFromTag . castMyTagWrap <=< tagRequest

321349

322350{-# INLINABLE runWithReplaceRequesterTWith #-}

@@ -365,7 +393,7 @@ traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIn

365393 pack = Entry

366394 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

367395 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?

369397 return (fmapCheap (IntMap.singleton n) myRequests, result)

370398 ndm' <- numberOccurrencesFrom 1 dm'

371399 (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

413441 pack = Entry

414442 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

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

417445 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

418446 ndm' <- numberOccurrencesFrom 1 dm'

419447 (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

427455 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

428456 requests <- holdIncremental requests0 requests'

429457 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 @@

11{-# LANGUAGE CPP #-}

2−-- | This module exports all of the user-facing functionality of the 'Spider'

3−-- 'Reflex' engine

2+-- |

3+-- Module:

4+-- Reflex.Spider

5+-- Description:

6+-- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine

47module Reflex.Spider

58 ( Spider

69 , SpiderTimeline

710 , Global

811 , SpiderHost

912 , runSpiderHost

10−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

1113 , runSpiderHostForTimeline

1214 , newSpiderTimeline

1315 , withSpiderTimeline

14−#endif

1516 -- * Deprecated

1617 , SpiderEnv

1718 ) where

1819

19−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

20−import Reflex.Class

21−#endif

2220import Reflex.Spider.Internal

src/Reflex/Spider/Internal.hs+247−74

@@ -9,7 +9,6 @@

99{-# LANGUAGE GADTs #-}

1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1111{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MagicHash #-}

1312{-# LANGUAGE MultiParamTypeClasses #-}

1413{-# LANGUAGE MultiWayIf #-}

1514{-# LANGUAGE RankNTypes #-}

@@ -21,28 +20,28 @@

2120#ifdef USE_REFLEX_OPTIMIZER

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

2322#endif

24−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

25−{-# OPTIONS_GHC -fno-warn-orphans #-}

26−#endif

2723-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

2824-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

2925module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

3026

31−import Control.Applicative

27+#if MIN_VERSION_base(4,10,0)

28+import Control.Applicative (liftA2)

29+#endif

3230import Control.Concurrent

3331import Control.Exception

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

32+import Control.Monad hiding (forM, forM_, mapM, mapM_)

3533import Control.Monad.Exception

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

34+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

3735import Control.Monad.Primitive

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

36+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

3937import Control.Monad.Ref

4038import Data.Align

4139import Data.Coerce

4240import Data.Dependent.Map (DMap, DSum (..))

4341import qualified Data.Dependent.Map as DMap

42+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

43+import qualified Data.FastMutableIntMap as FastMutableIntMap

4444import Data.Foldable hiding (concat, elem, sequence_)

45−import Data.Function

4645import Data.Functor.Constant

4746import Data.Functor.Misc

4847import Data.Functor.Product

@@ -50,20 +49,16 @@ import Data.GADT.Compare

5049import Data.IntMap.Strict (IntMap)

5150import qualified Data.IntMap.Strict as IntMap

5251import Data.IORef

53−import Data.List hiding (foldl')

54−import Data.Maybe

52+import Data.Maybe hiding (mapMaybe)

5553import Data.Monoid ((<>))

5654import Data.Proxy

5755import Data.These

5856import Data.Traversable

59−import Data.Word

60−import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

61−import qualified Data.FastMutableIntMap as FastMutableIntMap

57+import Data.Witherable (Filterable, mapMaybe)

6258import GHC.Exts

6359import GHC.IORef (IORef (..))

6460import GHC.Stack

6561import Reflex.FastWeak

66−import Reflex.FunctorMaybe

6762import System.IO.Unsafe

6863import System.Mem.Weak

6964import Unsafe.Coerce

@@ -78,27 +73,22 @@ import Data.Tree (Forest, Tree (..), drawForest)

7873

7974import Data.FastWeakBag (FastWeakBag)

8075import 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

8476import Data.Reflection

8577import Data.Some (Some)

8678import qualified Data.Some as Some

8779import Data.Type.Coercion

80+import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

81+import qualified Data.WeakBag as WeakBag

8882import qualified Reflex.Class

8983import qualified Reflex.Class as R

9084import qualified Reflex.Host.Class

91−#endif

9285import Reflex.NotReady.Class

9386import Reflex.Patch

9487import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

9588

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−

9989#ifdef DEBUG_TRACE_EVENTS

100−import System.IO (stderr)

10190import qualified Data.ByteString.Char8 as BS8

91+import System.IO (stderr)

10292#endif

10393

10494#ifdef DEBUG_TRACE_EVENTS

@@ -245,7 +235,7 @@ subscribeAndRead = unEvent

245235-- caching; if the computation function is very cheap, this is (much) more

246236-- efficient than 'push'

247237{-# 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

249239pushCheap !f e = Event $ \sub -> do

250240 (subscription, occ) <- subscribeAndRead e $ sub

251241 { subscriberPropagate = \a -> do

@@ -389,7 +379,7 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

389379eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

390380eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

391381

392−eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

382+eventHold :: Hold x p -> Event x p

393383eventHold !h = Event $ subscribeHoldEvent h

394384

395385eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

@@ -646,7 +636,7 @@ walkInvalidHeightParents s0 = do

646636#endif

647637

648638{-# 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)

650640subscribeHoldEvent = subscribeAndRead . holdEvent

651641

652642--------------------------------------------------------------------------------

@@ -718,13 +708,13 @@ data Dynamic x p = Dynamic

718708 , dynamicUpdated :: !(Event x p)

719709 }

720710

721−dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p

711+dynamicHold :: Hold x p -> Dynamic x p

722712dynamicHold !h = Dynamic

723713 { dynamicCurrent = behaviorHold h

724714 , dynamicUpdated = eventHold h

725715 }

726716

727−dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

717+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

728718dynamicHoldIdentity = dynamicHold

729719

730720dynamicConst :: PatchTarget p -> Dynamic x p

@@ -760,9 +750,7 @@ data Hold x p

760750#endif

761751 }

762752

763−-- | A statically allocated 'SpiderTimeline'; this is the only instance of

764−-- 'SpiderTimeline' that can used when using

765−-- -fspecialize-to-spidertimeline-global.

753+-- | A statically allocated 'SpiderTimeline'

766754data Global

767755

768756{-# NOINLINE globalSpiderTimelineEnv #-}

@@ -784,17 +772,9 @@ instance Eq (SpiderTimelineEnv x) where

784772 _ == _ = True -- Since only one exists of each type

785773

786774instance 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

794775 a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

795776 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

796777 else Nothing

797−#endif

798778

799779data EventEnv x

800780 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

@@ -864,11 +844,7 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where

864844 delayedRef <- asksEventEnv eventEnvDelayedMerges

865845 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

866846

867−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

868−class x ~ Global => HasSpiderTimeline x where

869−#else

870847class HasSpiderTimeline x where

871−#endif

872848 -- | Retrieve the current SpiderTimelineEnv

873849 spiderTimeline :: SpiderTimelineEnv x

874850

@@ -1152,14 +1128,18 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

11521128newInvalidatorPull :: Pull x a -> IO (Invalidator x)

11531129newInvalidatorPull p = return $! InvalidatorPull p

11541130

1155−instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1156− fmapMaybe f = push $ return . f

1131+instance HasSpiderTimeline x => Filterable (Event x) where

1132+ mapMaybe f = push $ return . f

11571133

11581134instance HasSpiderTimeline x => Align (Event x) where

11591135 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]

11611137

1162−newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

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+

1142+newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

11631143

11641144newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

11651145newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

@@ -1180,15 +1160,15 @@ zipDynWith f da db =

11801160 return $ Just $ Identity $ f a b

11811161 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

11821162

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)

11841164buildDynamic readV0 v' = do

1185− result <- liftIO $ newIORef $ Left (readV0, v')

1165+ result <- liftIO $ newIORef $ BuildDyn (readV0, v')

11861166 let !d = Dyn result

11871167 defer $ SomeDynInit d

11881168 return d

11891169

11901170unsafeBuildDynamic :: 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

11921172 where x = (readV0, v')

11931173

11941174-- ResultM can read behaviors and events

@@ -1237,8 +1217,8 @@ coincidence a = eventCoincidence $ Coincidence

12371217run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

12381218run roots after = do

12391219 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1240− t <- SpiderHost ask

1241− result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do

1220+ let t = spiderTimeline :: SpiderTimelineEnv x

1221+ result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

12421222 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

12431223 occBefore <- liftIO $ do

12441224 occBefore <- readIORef occRef

@@ -1398,14 +1378,21 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)

13981378getDynHold d = do

13991379 mh <- liftIO $ readIORef $ unDyn d

14001380 case mh of

1401− Right h -> return h

1402− Left (readV0, v') -> do

1381+ HoldDyn h -> return h

1382+ UnsafeDyn (readV0, v') -> do

14031383 holdInits <- getDeferralQueue

14041384 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

14051391 h <- hold v0 v'

1406− liftIO $ writeIORef (unDyn d) $ Right h

1392+ liftIO $ writeIORef (unDyn d) $ HoldDyn h

14071393 return h

14081394

1395+

14091396-- Always refers to 0

14101397{-# NOINLINE zeroRef #-}

14111398zeroRef :: IORef Height

@@ -2098,7 +2085,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

20982085

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

21002087runFrame :: 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

21022089 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

21032090 let go = do

21042091 result <- a

@@ -2139,7 +2126,7 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

21392126 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

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

21412128 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

21432130 {-

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

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

@@ -2254,13 +2241,204 @@ invalidate toReconnectRef wis = do

22542241-- Reflex integration

22552242--------------------------------------------------------------------------------

22562243

2257−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2258−-- When we're specializing, we include this from Reflex.Class instead, because

2259−-- it needs access to these types; when we're not, we want them here, so our

2260−-- instance isn't an orphan instance.

2261−#include "SpiderTimeline.include.hs"

2262−#include "SpiderTimelineHost.include.hs"

2244+-- | Designates the default, global Spider timeline

2245+data SpiderTimeline x

2246+type role SpiderTimeline nominal

2247+

2248+-- | The default, global Spider environment

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)

22632321#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

22642442

22652443unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

22662444unsafeNewSpiderTimelineEnv = do

@@ -2277,7 +2455,6 @@ unsafeNewSpiderTimelineEnv = do

22772455#endif

22782456 }

22792457

2280−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

22812458-- | Create a new SpiderTimelineEnv

22822459newSpiderTimeline :: IO (Some SpiderTimelineEnv)

22832460newSpiderTimeline = withSpiderTimeline (pure . Some.This)

@@ -2299,7 +2476,6 @@ withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> I

22992476withSpiderTimeline k = do

23002477 env <- unsafeNewSpiderTimelineEnv

23012478 reify env $ \s -> k $ localSpiderTimeline s env

2302−#endif

23032479

23042480newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

23052481

@@ -2307,7 +2483,6 @@ type ComputeM = EventM

23072483

23082484newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

23092485

2310−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

23112486instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

23122487 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

23132488 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

@@ -2361,7 +2536,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

23612536 mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

23622537 {-# INLINABLE fanInt #-}

23632538 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2364−#endif

23652539

23662540data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

23672541

@@ -2384,7 +2558,7 @@ instance MonadAtomicRef (EventM x) where

23842558 atomicModifyRef r f = liftIO $ atomicModifyRef r f

23852559

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

23882562

23892563instance Monad (SpiderHost x) where

23902564 {-# INLINABLE (>>=) #-}

@@ -2399,16 +2573,15 @@ instance Monad (SpiderHost x) where

23992573-- | Run an action affecting the global Spider timeline; this will be guarded by

24002574-- a mutex for that timeline

24012575runSpiderHost :: SpiderHost Global a -> IO a

2402−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv

2576+runSpiderHost (SpiderHost a) = a

24032577

2404−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

24052578-- | Run an action affecting a given Spider timeline; this will be guarded by a

24062579-- mutex for that timeline

24072580runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2408−runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2409−#endif

2581+runSpiderHostForTimeline (SpiderHost a) _ = a

24102582

2411−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2583+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2584+ deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

24122585

24132586instance Monad (SpiderHostFrame x) where

24142587 {-# INLINABLE (>>=) #-}

@@ -2420,7 +2593,7 @@ instance Monad (SpiderHostFrame x) where

24202593 {-# INLINABLE fail #-}

24212594 fail s = SpiderHostFrame $ fail s

24222595

2423−instance NotReady x (SpiderHostFrame x) where

2596+instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

24242597 notReadyUntil _ = pure ()

24252598 notReady = pure ()

24262599

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 #-}

12{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE DeriveTraversable #-}

25{-# LANGUAGE FlexibleContexts #-}

36{-# LANGUAGE MultiParamTypeClasses #-}

47{-# LANGUAGE RecursiveDo #-}

58{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE CPP #-}

9+{-# LANGUAGE TupleSections #-}

10+{-# LANGUAGE TypeFamilies #-}

711#ifdef USE_TEMPLATE_HASKELL

812{-# LANGUAGE TemplateHaskell #-}

913#endif

10−{-# LANGUAGE TypeFamilies #-}

14+-- |

15+-- Module:

16+-- Reflex.Time

17+-- Description:

18+-- Clocks, timers, and other time-related functions.

1119module Reflex.Time where

1220

1321import Reflex.Class

@@ -23,36 +31,50 @@ import Control.Monad

2331import Control.Monad.Fix

2432import Control.Monad.IO.Class

2533import Data.Align

34+import Data.Data (Data)

2635import Data.Fixed

36+import Data.Semigroup (Semigroup(..))

2737import Data.Sequence (Seq, (|>))

2838import qualified Data.Sequence as Seq

2939import Data.These

3040import Data.Time.Clock

3141import Data.Typeable

42+import GHC.Generics (Generic)

3243import System.Random

3344

45+-- | Metadata associated with a timer "tick"

3446data TickInfo

3547 = TickInfo { _tickInfo_lastUTC :: UTCTime

3648 -- ^ UTC time immediately after the last tick.

3749 , _tickInfo_n :: Integer

38− -- ^ Number of time periods since t0

50+ -- ^ Number of time periods or ticks since the start of the timer

3951 , _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.

4153 }

4254 deriving (Eq, Ord, Show, Typeable)

4355

44−-- | Special case of tickLossyFrom that uses the post-build event to start the

45−-- tick thread.

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.

58+-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread.

4659tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)

4760tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild

4861

49−-- | Send events over time with the given basis time and interval

50−-- 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

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+

70+-- | Fires an 'Event' approximately each time the provided interval elapses. If the system starts running behind, occurrences will be dropped rather than buffered.

71+-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the provided initial time.

5272tickLossyFrom

5373 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

5474 => NominalDiffTime

75+ -- ^ The length of a tick interval

5576 -> UTCTime

77+ -- ^ The basis time from which intervals count and with which the initial calculation of elapsed time will be made.

5678 -> Event t a

5779 -- ^ Event that starts a tick generation thread. Usually you want this to

5880 -- be something like the result of getPostBuild that only fires once. But

@@ -60,12 +82,12 @@ tickLossyFrom

6082 -> m (Event t TickInfo)

6183tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e

6284

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

6486tickLossyFrom'

6587 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

6688 => Event t (NominalDiffTime, UTCTime)

6789 -- ^ 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

6991 -- there could be uses for starting multiple timer threads.

7092 -> m (Event t TickInfo)

7193tickLossyFrom' e = do

@@ -76,12 +98,16 @@ tickLossyFrom' e = do

7698 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000

7799 cb (tick, pair)

78100

101+-- | Like 'tickLossy', but immediately calculates the first tick and provides a 'Dynamic' that is updated as ticks fire.

79102clockLossy :: (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)

80103clockLossy dt t0 = do

81104 initial <- liftIO $ getCurrentTick dt t0

82105 e <- tickLossy dt t0

83106 holdDyn initial e

84107

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.

85111getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo

86112getCurrentTick dt t0 = do

87113 t <- getCurrentTime

@@ -96,7 +122,7 @@ delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do

96122 cb a

97123

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

100126-- the current interval, with 0 representing the basis time

101127poissonLossyFrom

102128 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)

@@ -115,7 +141,7 @@ poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate

115141

116142

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

119145-- the current interval, with 0 representing the basis time.

120146-- Automatically begin sending events when the DOM is built

121147poissonLossy

@@ -222,6 +248,125 @@ batchOccurrences t newValues = do

222248 delayed <- delay t toDelay

223249 return $ tag buffer delayed

224250

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+

225370#ifdef USE_TEMPLATE_HASKELL

226371makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo

227372#else

@@ -237,4 +382,3 @@ tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime

237382tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3

238383{-# INLINE tickInfo_alreadyElapsed #-}

239384#endif

240−

src/Reflex/TriggerEvent/Base.hs+3−1

@@ -22,8 +22,10 @@ import Control.Monad.Ref

2222import Data.Coerce

2323import Data.Dependent.Sum

2424import Data.IORef

25+import Data.Monoid ((<>))

2526import qualified Data.Semigroup as S

2627import Reflex.Class

28+import Reflex.Adjustable.Class

2729import Reflex.Host.Class

2830import Reflex.PerformEvent.Class

2931import Reflex.PostBuild.Class

@@ -134,7 +136,7 @@ instance Adjustable t m => Adjustable t (TriggerEventT t m) where

134136-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.

135137instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where

136138 mempty = pure mempty

137− mappend = liftA2 mappend

139+ mappend = (<>)

138140

139141instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where

140142 (<>) = liftA2 (S.<>)

src/Reflex/Widget/Basic.hs+2

@@ -10,7 +10,9 @@ module Reflex.Widget.Basic where

1010

1111import Control.Monad.Fix (MonadFix)

1212import Data.Map (Map)

13+

1314import Reflex.Class

15+import Reflex.Adjustable.Class

1416import Reflex.Patch.MapWithMove

1517

1618

src/Reflex/Workflow.hs+15−2

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

1−{-# LANGUAGE ScopedTypeVariables #-}

21{-# 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."

310module Reflex.Workflow (

4− -- * Workflows

511 Workflow (..)

612 , workflow

713 , workflowView

@@ -13,25 +19,32 @@ import Control.Arrow ((***))

1319import Control.Monad.Fix (MonadFix)

1420

1521import Reflex.Class

22+import Reflex.Adjustable.Class

1623import Reflex.Network

1724import Reflex.NotReady.Class

1825import Reflex.PostBuild.Class

1926

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.

2029newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

2130

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

2232workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

2333workflow w0 = do

2434 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

2535 return $ fmap fst eResult

2636

37+-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'.

2738workflowView :: 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)

2839workflowView w0 = do

2940 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

3041 eReplace <- fmap switch $ hold never $ fmap snd eResult

3142 return $ fmap fst eResult

3243

44+-- | Map a function over a 'Workflow', possibly changing the resturn type.

3345mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

3446mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

3547

48+-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.

3649mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

3750mapWorkflowCheap 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 #-}

25module Main where

47import Control.Lens

58import 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

613import Data.These

714

815import Reflex

9−import Reflex.EventWriter

16+import Reflex.EventWriter.Base

1017import Test.Run

1118

1219main :: IO ()

@@ -23,6 +30,12 @@ main = do

2330 , These () ()

2431 ]

2532 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

2639 return ()

2740

2841unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])

@@ -42,3 +55,60 @@ testSimultaneous pulse = do

4255 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

4356 return ()

4457

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 #-}

27module Main where

49import Control.Monad

@@ -17,11 +22,11 @@ import Data.These

1722import Data.Functor.Misc

1823import Reflex.Patch

1924

20−import qualified Reflex.Spider.Internal as S

2125import qualified Reflex.Host.Class as Host

26+import qualified Reflex.Spider.Internal as S

2227

23−import System.Mem

2428import System.Exit

29+import System.Mem

2530

2631main :: IO ()

2732main = do

test/QueryT.hs+15−8

@@ -1,18 +1,21 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DeriveFunctor #-}

23{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE GeneralizedNewtypeDeriving #-}

55{-# LANGUAGE LambdaCase #-}

66{-# LANGUAGE RankNTypes #-}

7+{-# LANGUAGE StandaloneDeriving #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

710

811import Control.Lens

912import Control.Monad.Fix

1013import Data.Align

11−import Data.AppendMap (AppendMap)

1214import qualified Data.AppendMap as AMap

1315import Data.Functor.Misc

1416import Data.Map (Map)

1517import qualified Data.Map as Map

18+import Data.Map.Monoidal (MonoidalMap)

1619import Data.Semigroup

1720import Data.These

1821

@@ -27,14 +30,18 @@ instance Query MyQuery where

2730 type QueryResult MyQuery = ()

2831 crop _ _ = ()

2932

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

3134 type QueryResult (Selector k a) = Selector k (QueryResult a)

3235 crop q r = undefined

3336

34−newtype Selector k a = Selector { unSelector :: AppendMap k a }

37+newtype Selector k a = Selector { unSelector :: MonoidalMap k a }

3538 deriving (Show, Read, Eq, Ord, Functor)

3639

37−instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where

40+#if !(MIN_VERSION_monoidal_containers(0,4,1))

41+deriving instance Ord k => Align (MonoidalMap k)

42+#endif

43+

44+instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where

3845 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b

3946 where

4047 f = alignWith $ \case

@@ -44,14 +51,14 @@ instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where

4451 let z = x `mappend` y

4552 in if z == mempty then Nothing else Just z

4653

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

4855 mempty = Selector AMap.empty

4956 mappend = (<>)

5057

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

5259 negateG = fmap negateG

5360

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)

5562

5663main :: IO ()

5764main = do

test/Reflex/Bench/Focused.hs+1−1

@@ -184,7 +184,7 @@ switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges

184184

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

186186holdMapDyn :: (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

188188

189189 where

190190 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

5555runPure :: PurePlan a -> (a, IntSet)

5656runPure (PurePlan p) = runStateT p mempty $ 0

5757

58−relavantTimes :: IntSet -> IntSet

59−relavantTimes occs = IntSet.fromList [0..l + 1]

58+relevantTimes :: IntSet -> IntSet

59+relevantTimes occs = IntSet.fromList [0..l + 1]

6060 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

6161

6262testBehavior :: (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)

6464

6565testEvent :: (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)

6767

6868

6969

test/Reflex/Plan/Reflex.hs+2−2

@@ -74,13 +74,13 @@ deriving instance ReflexHost t => MonadFix (Plan t)

7474

7575

7676instance (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

7878 (e, ref) <- newEventWithTriggerRef

7979 modify (IntMap.unionWith mappend (firings ref))

8080 return e

8181

8282 where

83− firings ref = IntMap.fromList (makeFiring ref <$> occurances)

83+ firings ref = IntMap.fromList (makeFiring ref <$> occurrences)

8484 makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])

8585

8686

test/Reflex/Test/CrossImpl.hs+20−21

@@ -12,7 +12,6 @@

1212{-# LANGUAGE TypeFamilies #-}

1313{-# LANGUAGE TypeOperators #-}

1414{-# LANGUAGE UndecidableInstances #-}

15−module Reflex.Test.CrossImpl (test) where

1615

1716import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)

1817

@@ -20,21 +19,18 @@ import Control.Monad.Ref

2019import Reflex.Class

2120import Reflex.Dynamic

2221import Reflex.Host.Class

23−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

2422import qualified Reflex.Pure as P

2523import qualified Reflex.Spider.Internal as S

2624

2725import Control.Arrow (second, (&&&))

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

2927import 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 (..))

32−import qualified Data.Dependent.Map as DMap

28+import Data.Dependent.Map (DSum (..))

3329import Data.Foldable

34−import Data.Functor.Misc

3530import Data.Map.Strict (Map)

3631import qualified Data.Map.Strict as Map

3732import qualified Data.Set as Set

33+import Data.Monoid

3834import Data.Traversable

3935import System.Exit

4036import System.Mem

@@ -155,35 +151,35 @@ testCases =

155151 let e' = leftmost [e, e]

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

157153 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

159155 let e' = fmap (const e) e

160− e'' <- switchPromptly never e'

156+ e'' <- switchHoldPromptly never e'

161157 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

163159 let e' = fmap (const e) e

164− e'' <- switchPromptly never $ leftmost [e', e']

160+ e'' <- switchHoldPromptly never $ leftmost [e', e']

165161 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

167163 let e' = leftmost [e, e]

168− e'' <- switchPromptly never (fmap (const e) e')

164+ e'' <- switchHoldPromptly never (fmap (const e) e')

169165 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

171167 let e' = leftmost [e, e]

172− e'' <- switchPromptly never (fmap (const e') e)

168+ e'' <- switchHoldPromptly never (fmap (const e') e)

173169 return (b, e'')

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

175171 let e' = leftmost [e, e]

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

177173 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

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

180176 Just <$> headE e

181− e'' <- switchPromptly never e'

177+ e'' <- switchHoldPromptly never e'

182178 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

184180 let e' = flip pushAlways e $ \_ -> do

185− switchPromptly e never

186− e'' <- switchPromptly never e'

181+ switchHoldPromptly e never

182+ e'' <- switchHoldPromptly never e'

187183 return (b, e'')

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

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

@@ -233,6 +229,9 @@ testCases =

233229 rec result <- holdUniqDyn d

234230 d <- holdDyn (0 :: Int) e

235231 return (current result, updated result)

232+

233+

234+

236235 {-

237236 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

238237 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

@@ -248,8 +247,8 @@ splitRecombineEvent e =

248247 in leftmost [ea, eb]

249248

250249

251−test :: IO ()

252−test = do

250+main :: IO ()

251+main = do

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

254253 putStrLn $ "Test: " <> name

255254 testAgreement builder inputs

test/Reflex/Test/Micro.hs+77−16

@@ -3,6 +3,7 @@

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE RankNTypes #-}

89{-# LANGUAGE RecursiveDo #-}

@@ -23,6 +24,24 @@ import Data.Monoid

2324

2425import Prelude

2526

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+

2645{-# ANN testCases "HLint: ignore Functor law" #-}

2746testCases :: [(String, TestCase)]

2847testCases =

@@ -128,36 +147,36 @@ testCases =

128147 return $ coincidence $ flip pushAlways e $ const $ do

129148 switch <$> hold ("x" <$ e) (e <$ e)

130149

131− , testE "switchPromptly-1" $ do

150+ , testE "switchHoldPromptly-1" $ do

132151 e <- events1

133152 let e' = e <$ e

134− switchPromptly never $ e <$ e'

153+ switchHoldPromptly never $ e <$ e'

135154

136− , testE "switchPromptly-2" $ do

155+ , testE "switchHoldPromptly-2" $ do

137156 e <- events1

138− switchPromptly never $ deep (e <$ e)

157+ switchHoldPromptly never $ deep (e <$ e)

139158

140− , testE "switchPromptly-3" $ do

159+ , testE "switchHoldPromptly-3" $ do

141160 e <- events1

142− switchPromptly never $ (e <$ deep e)

161+ switchHoldPromptly never $ (e <$ deep e)

143162

144− , testE "switchPromptly-4" $ do

163+ , testE "switchHoldPromptly-4" $ do

145164 e <- events1

146− switchPromptly never $ (deep e <$ e)

165+ switchHoldPromptly never $ (deep e <$ e)

147166

148167 , testE "switch-5" $ do

149168 e <- events1

150169 switch <$> hold never (deep e <$ e)

151170

152− , testE "switchPromptly-5" $ do

171+ , testE "switchHoldPromptly-5" $ do

153172 e <- events1

154− switchPromptly never $ flip push e $

173+ switchHoldPromptly never $ flip push e $

155174 const (Just <$> headE e)

156175

157− , testE "switchPromptly-6" $ do

176+ , testE "switchHoldPromptly-6" $ do

158177 e <- events1

159− switchPromptly never $ flip pushAlways e $

160− const (switchPromptly e never)

178+ switchHoldPromptly never $ flip pushAlways e $

179+ const (switchHoldPromptly e never)

161180

162181 , testE "coincidence-1" $ do

163182 e <- events1

@@ -201,6 +220,14 @@ testCases =

201220 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo

202221 return $ pull $ sample =<< sample bb

203222

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+

204231 , testE "joinDyn" $ do

205232 e <- events1

206233 bb <- hold "b" e

@@ -223,6 +250,38 @@ testCases =

223250 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2

224251

225252 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+

226285 , testE "fan-1" $ do

227286 e <- fmap toMap <$> events1

228287 let es = select (fanMap e) . Const2 <$> values

@@ -264,14 +323,18 @@ testCases =

264323 return $ void e

265324 lazyHold

266325

326+

267327 ] where

268328

269329 events1, events2, events3 :: TestPlan t m => m (Event t String)

270330 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]

271331 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]

272−

273332 events3 = liftA2 mappend events1 events2

274333

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+

275338 values = "abcde"

276339 toMap str = Map.fromList $ map (\c -> (c, c)) str

277340

@@ -281,5 +344,3 @@ testCases =

281344

282345 deep e = leftmost [e, e]

283346 leftmost2 e1 e2 = leftmost [e1, e2]

284−

285−

test/Reflex/TestPlan.hs+2−2

@@ -26,8 +26,8 @@ import Reflex.Class

2626import Prelude

2727

2828class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where

29− -- | Speicify a plan of an input Event firing

30− -- Occurances must be in the future (i.e. Time > 0)

29+ -- | Specify a plan of an input Event firing

30+ -- Occurrences must be in the future (i.e. Time > 0)

3131 -- Initial specification is

3232

3333 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 #-}

25module Main where

47import Control.Lens

@@ -48,9 +51,8 @@ testOrdering :: ( Response m ~ Identity

4851 , Adjustable t m)

4952 => Event t ()

5053 -> m ()

51−testOrdering pulse = do

52− forM_ [10,9..1] $ \i -> requestingIdentity (RequestInt i <$ pulse)

53− return ()

54+testOrdering pulse = forM_ [10,9..1] $ \i ->

55+ requestingIdentity (RequestInt i <$ pulse)

5456

5557testSimultaneous :: ( Response m ~ Identity

5658 , Request m ~ RequestInt

test/Test/Run.hs+8

@@ -64,3 +64,11 @@ runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

6464runApp' app input = do

6565 let app' = fmap (AppOut (pure ())) . app

6666 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

44import Language.Haskell.HLint3 (hlint)

55import System.Directory

66import System.Exit (exitFailure, exitSuccess)

7−import System.FilePath.Find

87import System.FilePath

8+import System.FilePath.Find

1010main :: IO ()

1111main = do

@@ -20,6 +20,7 @@ main = do

2020 , "--ignore=Use >=>"

2121 , "--ignore=Use ."

2222 , "--ignore=Use unless"

23+ , "--ignore=Reduce duplication"

2324 , "--cpp-define=USE_TEMPLATE_HASKELL"

2425 ]

2526 recurseInto = and <$> sequence

@@ -31,7 +32,7 @@ main = do

3132 , let notElem' = liftOp notElem

3233 in filePath `notElem'` filePathExceptions pwd

3334 ]

34− files <- find recurseInto matchFile pwd

35+ files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

3536 ideas <- fmap concat $ forM files $ \f -> do

3637 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

3738 runHlint f

test/rootCleanup.hs+3−3

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

1−import Control.Monad

21import Control.Concurrent

2+import Control.Monad

3+import Data.IORef

34import Reflex

45import Reflex.Host.Class

5−import System.Mem

6−import Data.IORef

76import System.Exit

7+import System.Mem

99main :: IO ()

1010main = do

test/semantics.hs−2

@@ -50,5 +50,3 @@ main = do

5050 ]

5151

5252 makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests

53−

54−