4c2d1ed...develop · reflex

git.iko.soy/reflex

on develop help sign in

.github/workflows/haskell.yml+3−7

since splitsnapshots

unifiedsplit

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

1name: github-action

3−on: [push, pull_request]

3+on: [push, pull_request]

5jobs:

6 build:

@@ -8,12 +8,6 @@ jobs:

8 matrix:

9 ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']

10 os: ['ubuntu-latest', 'macos-latest']

11− exclude:

12− # There are some linker warnings in 802 on darwin that

13− # cause compilation to fail

14− # See https://github.com/NixOS/nixpkgs/issues/25139

15− - ghc: '8.0.2'

16− os: 'macos-latest'

17 runs-on: ${{ matrix.os }}

11 runs-on: ${{ matrix.os }}

19 name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}

13 name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}

@@ -43,3 +37,5 @@ jobs:

43 run: cabal build --enable-tests --enable-benchmarks all

37 run: cabal build --enable-tests --enable-benchmarks all

44 - name: Run tests

38 - name: Run tests

45 run: cabal test all

39 run: cabal test all

40+ - name: Build Docs

41+ run: cabal haddock

.travis.ymldeleted−173

@@ -1,173 +0,0 @@

1−# This Travis job script has been generated by a script via

2−#

3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'

4−#

5−# For more information, see https://github.com/haskell-CI/haskell-ci

6−#

7−# version: 0.3.20190814

8−#

9−language: c

10−dist: xenial

11−sudo: required

12−git:

13− # whether to recursively clone submodules

14− submodules: false

15−cache:

16− directories:

17− - $HOME/.cabal/packages

18− - $HOME/.cabal/store

19−before_cache:

20− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

21− # remove files that are regenerated by 'cabal update'

22− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

23− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

27− - rm -rfv $CABALHOME/packages/head.hackage

28−matrix:

29− include:

30− - compiler: ghcjs-8.4

31− addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}

32− - compiler: ghc-8.8.1

33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}

34− - compiler: ghc-8.6.5

35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}

36− - compiler: ghc-8.4.4

37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}

38−before_install:

39− - |

40− if [ "$TRAVIS_OS_NAME" = "linux" ]; then

41− sudo add-apt-repository -y ppa:hvr/ghcjs;

42− curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -

43− sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main'

44− sudo apt-get update;

45− sudo apt-get install $CC cabal-install-3.0 nodejs;

46− fi

47− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

48− - WITHCOMPILER="-w $HC"

49− - |

50− if echo $CC | grep -q ghcjs; then

51− GHCJS=true

52− HC=${HC}js

53− WITHCOMPILER="--ghcjs ${WITHCOMPILER}js"

54− else

55− GHCJS=false;

56− fi

57− - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi

58− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi

59− - HCPKG="$HC-pkg"

60− - unset CC

61− - CABAL=/opt/ghc/bin/cabal

62− - CABALHOME=$HOME/.cabal

63− - export PATH="$CABALHOME/bin:$PATH"

64− - TOP=$(pwd)

65− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"

66− - echo $HCNUMVER

67− - CABAL="$CABAL -vnormal+nowrap+markoutput"

68− - set -o pipefail

69− - |

70− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk

71− echo 'BEGIN { state = "output"; }' >> .colorful.awk

72− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk

73− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk

74− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk

75− echo ' if (state == "cabal") {' >> .colorful.awk

76− echo ' print blue($0)' >> .colorful.awk

77− echo ' } else {' >> .colorful.awk

78− echo ' print $0' >> .colorful.awk

79− echo ' }' >> .colorful.awk

80− echo '}' >> .colorful.awk

81− - cat .colorful.awk

82− - |

83− color_cabal_output () {

84− awk -f $TOP/.colorful.awk

85− }

86− - echo text | color_cabal_output

87−install:

88− - ${CABAL} --version

89− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

90− - node --version

91− - echo $GHCJS

92− - TEST=--enable-tests

93− - BENCH=--enable-benchmarks

94− - BENCH=--disable-benchmarks

95− - HEADHACKAGE=false

96− - rm -f $CABALHOME/config

97− - |

98− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config

99− echo "remote-build-reporting: anonymous" >> $CABALHOME/config

100− echo "write-ghc-environment-files: always" >> $CABALHOME/config

101− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config

102− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config

103− echo "world-file: $CABALHOME/world" >> $CABALHOME/config

104− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config

105− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config

106− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config

107− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config

108− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config

109− echo "install-dirs user" >> $CABALHOME/config

110− echo " prefix: $CABALHOME" >> $CABALHOME/config

111− echo "repository hackage.haskell.org" >> $CABALHOME/config

112− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config

113− - cat $CABALHOME/config

114− - rm -fv cabal.project cabal.project.local cabal.project.freeze

115− - travis_retry ${CABAL} v2-update -v

116− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi

117− # Generate cabal.project

118− - rm -rf cabal.project cabal.project.local cabal.project.freeze

119− - touch cabal.project

120− - |

121− echo "packages: ." >> cabal.project

122− - |

123− - cat cabal.project || true

124− - cat cabal.project.local || true

125− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

126− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output

127− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

128− - rm cabal.project.freeze

129−script:

130− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

131− # Packaging...

132− - ${CABAL} v2-sdist all | color_cabal_output

133− # Unpacking...

134− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

135− - cd ${DISTDIR} || false

136− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

137− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;

138− - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')"

139− # Generate cabal.project

140− - rm -rf cabal.project cabal.project.local cabal.project.freeze

141− - touch cabal.project

142− - |

143− echo "packages: ${PKGDIR_reflex}" >> cabal.project

144− - |

145− - cat cabal.project || true

146− - cat cabal.project.local || true

147− # Building...

148− # this builds all libraries and executables (without tests/benchmarks)

149− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

150− # Building with tests and benchmarks...

151− # build & run tests, build benchmarks

152− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

153− # Testing...

154− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

155− # cabal check...

156− - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check)

157− # haddock...

158− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

159− # Constraint sets

160− - rm -rf cabal.project.local

161− # Constraint set no-th

162− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output

163− # Constraint set old-these

164− - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi

165− # Constraint set old-witherable

166− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output

167− # Constraint set debug-propagation

168− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-propagation' all | color_cabal_output

169− # Constraint set debug-cycles

170− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-cycles' all | color_cabal_output

171−

172−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]

173−# EOF

ChangeLog.md+21−2

@@ -1,19 +1,38 @@

1# Revision history for reflex

3+## 0.8.2.0

5+* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.

7+## 0.8.1.1

9+* Allow newer hlint for older GHCs, and add upper bound for newer GHCs

10+

3## 0.8.1.0

11## 0.8.1.0

5* Add support for GHC 8.10

13* Add support for GHC 8.10

6−* Drop support for GHC 8.2.* and earlier

14+* Drop support for GHC < 8.4

8## 0.8.0.0

16## 0.8.0.0

10* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.

18* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.

12−## 0.7.2.0

20+## 0.7.2.0 -- *Deprecated*

21+

13* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.

22* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.

14* Extend some dependency version bounds

23* Extend some dependency version bounds

15* Fix HLint 3 test

24* Fix HLint 3 test

26+## 0.7.1.1

27+

28+*Backport release*.

29+Changes do not carry forward to 0.7.2.0.

30+

31+* Add support for GHC 8.10

32+* Drop support for GHC < 8.4

33+* Extend some dependency version bounds

34+* Fix HLint 3 test

35+

17## 0.7.1.0

36## 0.7.1.0

19* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.

38* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.

README.md+4−4

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

1−## [Reflex](https://reflex-frp.org/)

1+# [Reflex](https://reflex-frp.org/)

3−[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex/badge)](https://matrix.hackage.haskell.org/#/package/reflex) [![Travis CI](https://api.travis-ci.org/reflex-frp/reflex.svg?branch=master)](https://travis-ci.org/reflex-frp/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE)

3+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex/badge)](https://matrix.hackage.haskell.org/#/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE)

5Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse.

@@ -8,7 +8,7 @@ Reflex is a fully-deterministic, higher-order Functional Reactive Programming in

9**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**

11−### Resources

11+## Resources

13* [Official Website](https://reflex-frp.org)

14* [Quick Reference](Quickref.md)

@@ -18,6 +18,6 @@ Reflex is a fully-deterministic, higher-order Functional Reactive Programming in

18* [/r/reflexfrp](https://www.reddit.com/r/reflexfrp)

19* [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)

21−### Hacking

21+## Hacking

23From the root of a [Reflex Platform](https://github.com/reflex-frp/reflex-platform) checkout, run `./scripts/hack-on haskell-overlays/reflex-packages/dep/reflex`. This will check out the reflex source code into the `haskell-overlays/reflex-packages/dep/reflex` directory. You can then point that checkout at your fork, make changes, etc. Use the `./try-reflex` or `./scripts/work-on` scripts to start a shell in which you can test your changes.

reflex.cabal+7−6

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

1Name: reflex

2−Version: 0.8.1.0

2+Version: 0.8.2.0

3Synopsis: Higher-order Functional Reactive Programming

4Description:

5 Interactive programs without callbacks or side-effects.

@@ -29,7 +29,7 @@ extra-source-files:

30tested-with:

31 GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2,

32− GHCJS ==8.4

32+ GHCJS ==8.6

34flag use-reflex-optimizer

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

@@ -71,9 +71,10 @@ library

71 hs-source-dirs: src

72 build-depends:

73 MemoTrie == 0.6.*,

74− base >= 4.9 && < 4.15,

74+ base >= 4.11 && < 4.15,

75 bifunctors >= 5.2 && < 5.6,

76 comonad >= 5.0.4 && < 5.1,

77+ constraints >= 0.10 && <0.14,

77 constraints-extras >= 0.3 && < 0.4,

78 constraints-extras >= 0.3 && < 0.4,

78 containers >= 0.6 && < 0.7,

79 containers >= 0.6 && < 0.7,

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

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

@@ -96,7 +97,7 @@ library

96 time >= 1.4 && < 1.10,

97 time >= 1.4 && < 1.10,

97 transformers >= 0.5.6.0 && < 0.6,

98 transformers >= 0.5.6.0 && < 0.6,

98 unbounded-delays >= 0.1.0.0 && < 0.2,

99 unbounded-delays >= 0.1.0.0 && < 0.2,

99− witherable >= 0.3 && < 0.4

100+ witherable >= 0.3 && < 0.5

100

101

101 if flag(split-these)

102 if flag(split-these)

102 build-depends: these >= 1 && <1.2,

103 build-depends: these >= 1 && <1.2,

@@ -258,9 +259,9 @@ test-suite hlint

258 , filepath

259 , filepath

259 , filemanip

260 , filemanip

260 if impl(ghc >= 8.8)

261 if impl(ghc >= 8.8)

261− build-depends: hlint >= 3

262+ build-depends: hlint >= 3 && < 4

262 else

263 else

263− build-depends: hlint (< 2.1 || >= 2.2.2) && < 3

264+ build-depends: hlint (< 2.1 || >= 2.2.2) && < 4

264 if impl(ghcjs)

265 if impl(ghcjs)

265 buildable: False

266 buildable: False

266

267

src/Reflex/Requester/Base.hs+91−26

@@ -1,6 +1,7 @@

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

2-- 'Requester'.

3{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE ApplicativeDo #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

5{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE ExistentialQuantification #-}

@@ -32,6 +33,7 @@ module Reflex.Requester.Base

32 , requesterDataToList

33 , requesterDataToList

33 , singletonRequesterData

34 , singletonRequesterData

34 , matchResponsesWithRequests

35 , matchResponsesWithRequests

36+ , matchResponseMapWithRequests

35 , multiEntry

37 , multiEntry

36 , unMultiEntry

38 , unMultiEntry

37 , requesting'

39 , requesting'

@@ -56,6 +58,7 @@ import Control.Monad.Ref

56import Control.Monad.State.Strict

58import Control.Monad.State.Strict

57import Data.Bits

59import Data.Bits

58import Data.Coerce

60import Data.Coerce

61+import Data.Constraint

59import Data.Dependent.Map (DMap)

62import Data.Dependent.Map (DMap)

60import qualified Data.Dependent.Map as DMap

63import qualified Data.Dependent.Map as DMap

61import Data.Dependent.Sum (DSum (..))

64import Data.Dependent.Sum (DSum (..))

@@ -81,19 +84,51 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

82newtype RequesterData f = RequesterData (TagMap (Entry f))

85newtype RequesterData f = RequesterData (TagMap (Entry f))

87+emptyRequesterData :: RequesterData f

88+emptyRequesterData = RequesterData $ TagMap IntMap.empty

89+

84data RequesterDataKey a where

90data RequesterDataKey a where

85 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

91 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

86 RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

92 RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

87− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

93+ RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

88 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

94 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

90singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

96singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

91singletonRequesterData rdk v = case rdk of

97singletonRequesterData rdk v = case rdk of

92 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

98 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

93 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

99 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

94− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

100+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents

101+ { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

102+ , _multi2Contents_dict = Dict

103+ }

95 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

105

106+mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f

107+mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b

108+

109+mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)

110+mergeTagMap (TagMap m) (TagMap n) =

111+ TagMap $ IntMap.unionWithKey (g' combiner) m n

112+ where

113+ combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a

114+ combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of

115+ MyTagType_Single -> a

116+ MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b

117+ MyTagType_Multi2 -> case _multi2Contents_dict a of

118+ Dict -> Multi2Contents

119+ { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)

120+ , _multi2Contents_dict = Dict

121+ }

122+ MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b

123+ g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any

124+ g' f rawKey a b =

125+ let k = MyTag rawKey :: MyTag a

126+ fromAny :: Any -> Entry f a

127+ fromAny = unsafeCoerce

128+ toAny :: Entry f a -> Any

129+ toAny = unsafeCoerce

130+ in toAny $ f k (fromAny a) (fromAny b)

131+

97requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

98requesterDataToList (RequesterData m) = do

133requesterDataToList (RequesterData m) = do

99 k :=> Entry e <- tagMapToList m

134 k :=> Entry e <- tagMapToList m

@@ -103,11 +138,12 @@ requesterDataToList (RequesterData m) = do

103 (k', e') <- IntMap.toList e

138 (k', e') <- IntMap.toList e

104 k'' :=> e'' <- requesterDataToList e'

139 k'' :=> e'' <- requesterDataToList e'

105 return $ RequesterDataKey_Multi k k' k'' :=> e''

140 return $ RequesterDataKey_Multi k k' k'' :=> e''

106− MyTagType_Multi2 -> do

141+ MyTagType_Multi2 -> case _multi2Contents_dict e of

142+ Dict -> do

107− (k', e') <- Map.toList e

143+ (k', e') <- Map.toList $ _multi2Contents_values e

108− (k'', e'') <- IntMap.toList e'

144+ (k'', e'') <- IntMap.toList e'

109− k''' :=> e''' <- requesterDataToList e''

145+ k''' :=> e''' <- requesterDataToList e''

110− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

146+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

111 MyTagType_Multi3 -> do

147 MyTagType_Multi3 -> do

112 (k', e') <- IntMap.toList e

148 (k', e') <- IntMap.toList e

113 (k'', e'') <- IntMap.toList e'

149 (k'', e'') <- IntMap.toList e'

@@ -135,7 +171,13 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith

135 go k (Entry request) = Entry <$> case myKeyType k of

171 go k (Entry request) = Entry <$> case myKeyType k of

136 MyTagType_Single -> f request

172 MyTagType_Single -> f request

137 MyTagType_Multi -> traverse (traverseRequesterData f) request

173 MyTagType_Multi -> traverse (traverseRequesterData f) request

174+ MyTagType_Multi2 -> case request of

175+ Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do

138− MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

176+ v <- traverse (traverse (traverseRequesterData f)) request'

177+ pure $ Multi2Contents

178+ { _multi2Contents_values = v

179+ , _multi2Contents_dict = Dict

180+ }

139 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

140

182

141-- | 'traverseRequesterData' with its arguments flipped

183-- | 'traverseRequesterData' with its arguments flipped

@@ -179,9 +221,14 @@ instance MyTagTypeOffset Multi3 where

179type family EntryContents request a where

221type family EntryContents request a where

180 EntryContents request (Single a) = request a

222 EntryContents request (Single a) = request a

181 EntryContents request Multi = IntMap (RequesterData request)

223 EntryContents request Multi = IntMap (RequesterData request)

182− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

224+ EntryContents request (Multi2 k) = Multi2Contents k request

183 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

184

226

227+data Multi2Contents k request = Multi2Contents

228+ { _multi2Contents_dict :: {-# UNPACK #-} !(Dict (GCompare k)) -- This is a Dict instead of an existential context because we only want to use it in certain circumstances

229+ , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))

230+ }

231+

185newtype Entry request x = Entry { unEntry :: EntryContents request x }

232newtype Entry request x = Entry { unEntry :: EntryContents request x }

186

233

187{-# INLINE singleEntry #-}

234{-# INLINE singleEntry #-}

@@ -310,7 +357,7 @@ tagRequest req = do

310 return t

357 return t

311

358

312{-# INLINE responseFromTag #-}

359{-# INLINE responseFromTag #-}

313−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

360+responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

314responseFromTag (MyTagWrap t) = do

361responseFromTag (MyTagWrap t) = do

315 responses :: EventSelectorInt t Any <- RequesterT ask

362 responses :: EventSelectorInt t Any <- RequesterT ask

316 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

@@ -440,9 +487,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

440 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

441 responses = fanMap $ fmapCheap unpack response

488 responses = fanMap $ fmapCheap unpack response

442 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

443− unpack = unEntry

490+ unpack = _multi2Contents_values . unEntry

444 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

445− pack = Entry

492+ pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }

446 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

447 f' k (Compose (n, v)) = do

494 f' k (Compose (n, v)) = do

448 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

@@ -463,9 +510,6 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

463data Decoder rawResponse response =

510data Decoder rawResponse response =

464 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

465

512

466−-- | Matches incoming responses with previously-sent requests

467−-- and uses the provided request "decoder" function to process

468−-- incoming responses.

469matchResponsesWithRequests

513matchResponsesWithRequests

470 :: forall t rawRequest rawResponse request response m.

514 :: forall t rawRequest rawResponse request response m.

471 ( MonadFix m

515 ( MonadFix m

@@ -484,7 +528,30 @@ matchResponsesWithRequests

484 )

528 )

485 -- ^ A map of outgoing wire-format requests and an event of responses keyed

529 -- ^ A map of outgoing wire-format requests and an event of responses keyed

486 -- by the 'RequesterData' key of the associated outgoing request

530 -- by the 'RequesterData' key of the associated outgoing request

487−matchResponsesWithRequests f send recv = do

531+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv

532+

533+-- | Matches incoming responses with previously-sent requests

534+-- and uses the provided request "decoder" function to process

535+-- incoming responses.

536+matchResponseMapWithRequests

537+ :: forall t rawRequest rawResponse request response m.

538+ ( MonadFix m

539+ , MonadHold t m

540+ , Reflex t

541+ )

542+ => (forall a. request a -> (rawRequest, rawResponse -> response a))

543+ -- ^ Given a request (from 'Requester'), produces the wire format of the

544+ -- request and a function used to process the associated response

545+ -> Event t (RequesterData request)

546+ -- ^ The outgoing requests

547+ -> Event t (Map Int rawResponse)

548+ -- ^ A map of incoming responses, tagged by an identifying key

549+ -> m ( Event t (Map Int rawRequest)

550+ , Event t (RequesterData response)

551+ )

552+ -- ^ A map of outgoing wire-format requests and an event of responses keyed

553+ -- by the 'RequesterData' key of the associated outgoing request

554+matchResponseMapWithRequests f send recv = do

488 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

489 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

490 holdIncremental mempty $ leftmost

557 holdIncremental mempty $ leftmost

@@ -526,17 +593,15 @@ matchResponsesWithRequests f send recv = do

526 processIncoming

593 processIncoming

527 :: Incremental t (PatchMap Int (Decoder rawResponse response))

594 :: Incremental t (PatchMap Int (Decoder rawResponse response))

528 -- A map of outstanding expected responses

595 -- A map of outstanding expected responses

529− -> Event t (Int, rawResponse)

596+ -> Event t (Map Int rawResponse)

530 -- A incoming response paired with its identifying key

597 -- A incoming response paired with its identifying key

531 -> Event t (RequesterData response, PatchMap Int v)

598 -> Event t (RequesterData response, PatchMap Int v)

532 -- The decoded response and a patch that clears the outstanding responses queue

599 -- The decoded response and a patch that clears the outstanding responses queue

533− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

600+ processIncoming waitingFor inc = flip push inc $ \rspMap -> do

534 wf <- sample $ currentIncremental waitingFor

601 wf <- sample $ currentIncremental waitingFor

535− case Map.lookup n wf of

536− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

537− Just (Decoder k rspF) -> do

602+ let match rawRsp (Decoder k rspF) =

538− let rsp = rspF rawRsp

603+ let rsp = rspF rawRsp

539− return $ Just

540− ( singletonRequesterData k rsp

604+ in singletonRequesterData k rsp

541− , PatchMap $ Map.singleton n Nothing

605+ matches = Map.intersectionWith match rspMap wf

542− )

606+ pure $ if Map.null matches then Nothing else Just

607+ (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)