reflex 0.6.3 → 0.6.4
raw patch · 26 files changed
+912/−1431 lines, 26 filesdep +constraintsdep +hspecdep +patchdep ~basedep ~constraints-extrasdep ~containers
Dependencies added: constraints, hspec, patch, proctest, text
Dependency ranges changed: base, constraints-extras, containers, dependent-map, dependent-sum, haskell-src-exts, lens, mtl, profunctors, ref-tf, semialign, template-haskell, these, time, transformers, witherable
Files
- ChangeLog.md +14/−0
- reflex.cabal +98/−23
- src/Data/AppendMap.hs +1/−1
- src/Data/FastMutableIntMap.hs +7/−3
- src/Data/Functor/Misc.hs +0/−234
- src/Data/Map/Misc.hs +1/−1
- src/Reflex/Adjustable/Class.hs +1/−1
- src/Reflex/Class.hs +10/−6
- src/Reflex/Dynamic.hs +2/−1
- src/Reflex/DynamicWriter/Base.hs +1/−1
- src/Reflex/Patch.hs +0/−46
- src/Reflex/Patch/Class.hs +0/−34
- src/Reflex/Patch/DMap.hs +0/−82
- src/Reflex/Patch/DMapWithMove.hs +0/−363
- src/Reflex/Patch/IntMap.hs +0/−59
- src/Reflex/Patch/Map.hs +0/−55
- src/Reflex/Patch/MapWithMove.hs +0/−270
- src/Reflex/Query/Base.hs +6/−1
- src/Reflex/Query/Class.hs +40/−0
- src/Reflex/Spider/Internal.hs +432/−244
- src/Reflex/Widget/Basic.hs +1/−1
- test/Adjustable.hs +62/−0
- test/DebugCycles.hs +171/−0
- test/GC.hs +1/−2
- test/QueryT.hs +1/−1
- test/RequesterT.hs +63/−2
ChangeLog.md view
@@ -1,5 +1,19 @@ # Revision history for reflex +## 0.6.4++* Support GHC 8.8++* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation++* The `Reflex.Patch.*` modules were moved to the `patch` library.+ They are `Data.Patch.*` there, but reexported under their old names for backwards compatability here.++* Additional instances for `Query` classes for basic types.++* Add cabal flags `debug-propagation` and `debug-event-cycles` to build in debugging+ code for performance and for cyclic dependencies between events+ ## 0.6.3 * `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.
reflex.cabal view
@@ -1,5 +1,5 @@ Name: reflex-Version: 0.6.3+Version: 0.6.4 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3@@ -9,7 +9,7 @@ Stability: Experimental Category: FRP Build-type: Simple-Cabal-version: >=1.9.2+Cabal-version: 1.22 homepage: https://reflex-frp.org bug-reports: https://github.com/reflex-frp/reflex/issues extra-source-files:@@ -18,7 +18,7 @@ ChangeLog.md tested-with:- GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5,+ GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1, GHCJS ==8.4 flag use-reflex-optimizer@@ -41,16 +41,27 @@ default: False manual: True +flag debug-propagation+ description: Enable debugging of spider internals+ default: False+ manual: True++flag debug-cycles+ description: Enable debugging of event cycles+ default: False+ manual: True+ flag split-these description: Use split these/semialign packages manual: False default: True library+ default-language: Haskell2010 hs-source-dirs: src build-depends: MemoTrie == 0.6.*,- base >= 4.9 && < 4.13,+ base >= 4.9 && < 4.14, bifunctors >= 5.2 && < 5.6, comonad >= 5.0.4 && < 5.1, constraints-extras >= 0.3 && < 0.4,@@ -61,16 +72,17 @@ lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, mtl >= 2.1 && < 2.3,+ patch >= 0.0.1 && < 0.1, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.8,- profunctors >= 5.3 && < 5.5,+ profunctors >= 5.3 && < 5.6, random == 1.1.*, ref-tf == 0.4.*, reflection == 2.1.*, semigroupoids >= 4.0 && < 6, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8,- time >= 1.4 && < 1.9,+ time >= 1.4 && < 1.10, transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, witherable >= 0.3 && < 0.3.2@@ -88,7 +100,6 @@ Data.AppendMap, Data.FastMutableIntMap, Data.FastWeakBag,- Data.Functor.Misc, Data.Map.Misc, Data.WeakBag, Reflex,@@ -110,13 +121,6 @@ Reflex.Host.Class, Reflex.Network, Reflex.NotReady.Class,- Reflex.Patch,- Reflex.Patch.Class,- Reflex.Patch.DMap,- Reflex.Patch.DMapWithMove,- Reflex.Patch.IntMap,- Reflex.Patch.Map,- Reflex.Patch.MapWithMove, Reflex.PerformEvent.Base, Reflex.PerformEvent.Class, Reflex.PostBuild.Base,@@ -135,6 +139,16 @@ Reflex.Widget.Basic, Reflex.Workflow + reexported-modules:+ patch:Data.Functor.Misc,+ patch:Data.Patch as Reflex.Patch,+ patch:Data.Patch.Class as Reflex.Patch.Class,+ patch:Data.Patch.DMap as Reflex.Patch.DMap,+ patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove,+ patch:Data.Patch.IntMap as Reflex.Patch.IntMap,+ patch:Data.Patch.Map as Reflex.Patch.Map,+ patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove+ ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively if flag(debug-trace-events)@@ -146,13 +160,19 @@ build-depends: ghc exposed-modules: Reflex.Optimizer + if flag(debug-propagation)+ cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION++ if flag(debug-cycles)+ cpp-options: -DDEBUG_CYCLES+ if flag(use-template-haskell) cpp-options: -DUSE_TEMPLATE_HASKELL build-depends: dependent-sum >= 0.6 && < 0.7,- haskell-src-exts >= 1.16 && < 1.22,+ haskell-src-exts >= 1.16 && < 1.23, haskell-src-meta >= 0.6 && < 0.9,- template-haskell >= 2.9 && < 2.15+ template-haskell >= 2.9 && < 2.16 exposed-modules: Reflex.Dynamic.TH other-extensions: TemplateHaskell@@ -167,6 +187,7 @@ build-depends: ghcjs-base test-suite semantics+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: semantics.hs hs-source-dirs: test@@ -192,6 +213,7 @@ Reflex.TestPlan test-suite CrossImpl+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Reflex/Test/CrossImpl.hs hs-source-dirs: test@@ -213,6 +235,7 @@ Reflex.Plan.Pure test-suite hlint+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: hlint.hs hs-source-dirs: test@@ -225,6 +248,7 @@ buildable: False test-suite EventWriterT+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: EventWriterT.hs hs-source-dirs: test@@ -244,30 +268,59 @@ build-depends: these-lens other-modules:- Reflex.Test- Reflex.TestPlan- Reflex.Plan.Reflex- Reflex.Plan.Pure Test.Run -test-suite RequesterT+test-suite DebugCycles+ default-language: Haskell2010 type: exitcode-stdio-1.0- main-is: RequesterT.hs+ main-is: DebugCycles.hs hs-source-dirs: test+ ghc-options: -threaded build-depends: base , containers , deepseq- , dependent-sum , dependent-map+ , dependent-sum+ , hspec , lens , mtl , these , transformers , reflex , ref-tf+ , witherable+ , proctest + if flag(split-these)+ build-depends: these-lens, semialign++ other-modules:+ Test.Run+++test-suite RequesterT+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: RequesterT.hs+ hs-source-dirs: test+ build-depends: base+ , constraints+ , constraints-extras+ , containers+ , deepseq+ , dependent-map+ , dependent-sum+ , lens+ , mtl+ , ref-tf+ , reflex+ , text+ , these+ , transformers++ if flag(split-these) build-depends: these-lens other-modules:@@ -275,7 +328,23 @@ Reflex.Plan.Pure Test.Run +test-suite Adjustable+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Adjustable.hs+ hs-source-dirs: test+ build-depends: base+ , containers+ , dependent-sum+ , reflex+ , ref-tf+ , these++ other-modules:+ Test.Run+ test-suite QueryT+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: QueryT.hs hs-source-dirs: test@@ -287,6 +356,7 @@ , lens , monoidal-containers , mtl+ , patch , ref-tf , reflex , these@@ -302,6 +372,7 @@ Reflex.Plan.Pure test-suite GC-Semantics+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: GC.hs hs-source-dirs: test@@ -311,6 +382,7 @@ , dependent-map , deepseq , mtl+ , patch , these , transformers , reflex@@ -326,6 +398,7 @@ Test.Run test-suite rootCleanup+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: rootCleanup.hs hs-source-dirs: test@@ -343,6 +416,7 @@ Test.Run benchmark spider-bench+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench test main-is: Main.hs@@ -367,6 +441,7 @@ Reflex.Bench.Focused benchmark saulzar-bench+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench test c-sources: bench-cbits/checkCapability.c
src/Data/AppendMap.hs view
@@ -71,7 +71,7 @@ then Nothing else Just bs --- TODO: Move instances to `Reflex.Patch`+-- TODO: Move instances to `Data.Patch` -- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details. showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String showTree = coerce (Map.showTree :: Map k a -> String)
src/Data/FastMutableIntMap.hs view
@@ -21,6 +21,7 @@ , patchIntMapNewElements , patchIntMapNewElementsMap , getDeletions+ , toList ) where --TODO: Pure JS version@@ -34,8 +35,8 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IORef-import Reflex.Patch.Class-import Reflex.Patch.IntMap+import Data.Patch.Class+import Data.Patch.IntMap -- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO. -- Operations on 'FastMutableIntMap' run in IO.@@ -84,10 +85,13 @@ writeIORef r IntMap.empty return result --- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Reflex.Patch.IntMap'),+-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'), -- and returns an 'IntMap' with the modified keys and values. applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a) applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do v <- readIORef r writeIORef r $! applyAlways p v return $ IntMap.intersection v m++toList :: FastMutableIntMap a -> IO [(Int, a)]+toList (FastMutableIntMap r) = IntMap.toList <$> readIORef r
− src/Data/Functor/Misc.hs
@@ -1,234 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif--- | This module provides types and functions with no particular theme, but--- which are relevant to the use of 'Functor'-based datastructures like--- 'Data.Dependent.Map.DMap'.-module Data.Functor.Misc- ( -- * Const2- Const2 (..)- , unConst2- , dmapToMap- , dmapToIntMap- , dmapToMapWith- , mapToDMap- , weakenDMapWith- -- * WrapArg- , WrapArg (..)- -- * Convenience functions for DMap- , mapWithFunctorToDMap- , intMapWithFunctorToDMap- , mapKeyValuePairsMonotonic- , combineDMapsWithKey- , EitherTag (..)- , dmapToThese- , eitherToDSum- , dsumToEither- , ComposeMaybe (..)- ) where--import Control.Applicative ((<$>))-import Control.Monad.Identity-import Data.Dependent.Map (DMap)-import qualified Data.Dependent.Map as DMap-import Data.Dependent.Sum-import Data.GADT.Compare-import Data.GADT.Show-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Some (Some(Some))-import Data.These-import Data.Typeable hiding (Refl)------------------------------------------------------------------------------------- Const2------------------------------------------------------------------------------------- | 'Const2' stores a value of a given type 'k' and ensures that a particular--- type 'v' is always given for the last type parameter-data Const2 :: * -> x -> x -> * where- Const2 :: k -> Const2 k v v- deriving (Typeable)---- | Extract the value from a Const2-unConst2 :: Const2 k v v' -> k-unConst2 (Const2 k) = k--deriving instance Eq k => Eq (Const2 k v v')-deriving instance Ord k => Ord (Const2 k v v')-deriving instance Show k => Show (Const2 k v v')-deriving instance Read k => Read (Const2 k v v)--instance Show k => GShow (Const2 k v) where- gshowsPrec n x@(Const2 _) = showsPrec n x--instance Eq k => GEq (Const2 k v) where- geq (Const2 a) (Const2 b) =- if a == b- then Just Refl- else Nothing--instance Ord k => GCompare (Const2 k v) where- gcompare (Const2 a) (Const2 b) = case compare a b of- LT -> GLT- EQ -> GEQ- GT -> GGT---- | Convert a 'DMap' to a regular 'Map'-dmapToMap :: DMap (Const2 k v) Identity -> Map k v-dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList---- | Convert a 'DMap' to an 'IntMap'-dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v-dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList---- | Convert a 'DMap' to a regular 'Map', applying the given function to remove--- the wrapping 'Functor'-dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'-dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList---- | Convert a regular 'Map' to a 'DMap'-mapToDMap :: Map k v -> DMap (Const2 k v) Identity-mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList---- | Convert a regular 'Map', where the values are already wrapped in a functor,--- to a 'DMap'-mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f-mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList---- | Convert a regular 'IntMap', where the values are already wrapped in a--- functor, to a 'DMap'-intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f-intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList---- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with--- the keys, using a function to remove the wrapping 'Functor'-weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'-weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList------------------------------------------------------------------------------------- WrapArg------------------------------------------------------------------------------------- | 'WrapArg' can be used to tag a value in one functor with a type--- representing another functor. This was primarily used with dependent-map <--- 0.2, in which the value type was not wrapped in a separate functor.-data WrapArg :: (k -> *) -> (k -> *) -> * -> * where- WrapArg :: f a -> WrapArg g f (g a)--deriving instance Eq (f a) => Eq (WrapArg g f (g' a))-deriving instance Ord (f a) => Ord (WrapArg g f (g' a))-deriving instance Show (f a) => Show (WrapArg g f (g' a))-deriving instance Read (f a) => Read (WrapArg g f (g a))--instance GEq f => GEq (WrapArg g f) where- geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b--instance GCompare f => GCompare (WrapArg g f) where- gcompare (WrapArg a) (WrapArg b) = case gcompare a b of- GLT -> GLT- GEQ -> GEQ- GGT -> GGT------------------------------------------------------------------------------------- Convenience functions for DMap------------------------------------------------------------------------------------- | Map over all key/value pairs in a 'DMap', potentially altering the key as--- well as the value. The provided function MUST preserve the ordering of the--- keys, or the resulting 'DMap' will be malformed.-mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'-mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList--{-# INLINE combineDMapsWithKey #-}--- | Union two 'DMap's of different types, yielding another type. Each key that--- is present in either input map will be present in the output.-combineDMapsWithKey :: forall f g h i.- GCompare f- => (forall a. f a -> These (g a) (h a) -> i a)- -> DMap f g- -> DMap f h- -> DMap f i-combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)- where go :: [DSum f g] -> [DSum f h] -> [DSum f i]- go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs- go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs- go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of- GLT -> (gk :=> f gk (This gv)) : go gs' hs- GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'- GGT -> (hk :=> f hk (That hv)) : go gs hs'---- | Extract the values of a 'DMap' of 'EitherTag's.-dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)-dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of- (Nothing, Nothing) -> Nothing- (Just (Identity a), Nothing) -> Just $ This a- (Nothing, Just (Identity b)) -> Just $ That b- (Just (Identity a), Just (Identity b)) -> Just $ These a b---- | Tag type for 'Either' to use it as a 'DSum'.-data EitherTag l r a where- LeftTag :: EitherTag l r l- RightTag :: EitherTag l r r- deriving (Typeable)--deriving instance Show (EitherTag l r a)-deriving instance Eq (EitherTag l r a)-deriving instance Ord (EitherTag l r a)--instance GEq (EitherTag l r) where- geq a b = case (a, b) of- (LeftTag, LeftTag) -> Just Refl- (RightTag, RightTag) -> Just Refl- _ -> Nothing--instance GCompare (EitherTag l r) where- gcompare a b = case (a, b) of- (LeftTag, LeftTag) -> GEQ- (LeftTag, RightTag) -> GLT- (RightTag, LeftTag) -> GGT- (RightTag, RightTag) -> GEQ--instance GShow (EitherTag l r) where- gshowsPrec _ a = case a of- LeftTag -> showString "LeftTag"- RightTag -> showString "RightTag"---- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.-eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity-eitherToDSum = \case- Left a -> (LeftTag :=> Identity a)- Right b -> (RightTag :=> Identity b)---- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.-dsumToEither :: DSum (EitherTag a b) Identity -> Either a b-dsumToEither = \case- (LeftTag :=> Identity a) -> Left a- (RightTag :=> Identity b) -> Right b------------------------------------------------------------------------------------- ComposeMaybe------------------------------------------------------------------------------------- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would--- make the 'f' parameter have a nominal type role. We need f to be--- representational so that we can use safe 'coerce'.-newtype ComposeMaybe f a =- ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)--deriving instance Functor f => Functor (ComposeMaybe f)
src/Data/Map/Misc.hs view
@@ -43,7 +43,7 @@ -- |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@. ----- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'.+-- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'. applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) where (deletions, insertions) = Map.mapEither maybeToEither patch
src/Reflex/Adjustable/Class.hs view
@@ -39,7 +39,7 @@ import Data.Map (Map) import Reflex.Class-import Reflex.Patch.DMapWithMove+import Data.Patch.DMapWithMove -- | A 'Monad' that supports adjustment over time. After an action has been -- run, if the given events fire, it will adjust itself so that its net effect
src/Reflex/Class.hs view
@@ -29,7 +29,7 @@ -- convenience functions for working with 'Event's, 'Behavior's, and other -- signals. module Reflex.Class- ( module Reflex.Patch+ ( module Data.Patch -- * Primitives , Reflex (..) , mergeInt@@ -200,7 +200,7 @@ import qualified Data.Dependent.Map as DMap import Data.Functor.Compose import Data.Functor.Product-import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..))+import Data.GADT.Compare (GEq (..), GCompare (..)) import Data.FastMutableIntMap (PatchIntMap) import Data.Foldable import Data.Functor.Bind@@ -210,17 +210,18 @@ import qualified Data.IntMap.Strict as IntMap import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map)-import Data.Semigroup (Semigroup, sconcat, stimes, (<>))+import Data.Semigroup (Semigroup (..)) import Data.Some (Some(Some)) import Data.String import Data.These import Data.Type.Coercion+import Data.Type.Equality ((:~:) (..)) import Data.Witherable (Filterable(..)) import qualified Data.Witherable as W import Reflex.FunctorMaybe (FunctorMaybe) import qualified Reflex.FunctorMaybe-import Reflex.Patch-import qualified Reflex.Patch.MapWithMove as PatchMapWithMove+import Data.Patch+import qualified Data.Patch.MapWithMove as PatchMapWithMove import Debug.Trace (trace) @@ -286,7 +287,8 @@ -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a- -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring+ -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring.+ -- You maybe looking for '@switchHold@ @never@' instead. coincidence :: Event t (Event t a) -> Event t a -- | Extract the 'Behavior' of a 'Dynamic'. current :: Dynamic t a -> Behavior t a@@ -662,7 +664,9 @@ a >>= f = pull $ sample a >>= sample . f -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above. return = constant+#if !MIN_VERSION_base(4,13,0) fail = error "Monad (Behavior t) does not support fail"+#endif instance (Reflex t, Monoid a) => Monoid (Behavior t a) where mempty = constant mempty
src/Reflex/Dynamic.hs view
@@ -87,11 +87,12 @@ import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..))-import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) import Data.Map (Map) import Data.Maybe import Data.Monoid ((<>)) import Data.These+import Data.Type.Equality ((:~:) (..)) import Debug.Trace
src/Reflex/DynamicWriter/Base.hs view
@@ -44,7 +44,7 @@ import Reflex.DynamicWriter.Class import Reflex.EventWriter.Class (EventWriter, tellEvent) import Reflex.Host.Class-import qualified Reflex.Patch.MapWithMove as MapWithMove+import qualified Data.Patch.MapWithMove as MapWithMove import Reflex.PerformEvent.Class import Reflex.PostBuild.Class import Reflex.Query.Class
− src/Reflex/Patch.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--- |--- Module:--- Reflex.Patch--- Description:--- This module defines the 'Patch' class, which is used by Reflex to manage--- changes to 'Reflex.Class.Incremental' values.-module Reflex.Patch- ( module Reflex.Patch- , module X- ) where--import Reflex.Patch.Class as X-import Reflex.Patch.DMap as X hiding (getDeletions)-import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,- patchDMapWithMoveToPatchMapWithMoveWith,- traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,- unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)-import Reflex.Patch.IntMap as X hiding (getDeletions)-import Reflex.Patch.Map as X-import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,- patchMapWithMoveNewElementsMap, unPatchMapWithMove,- unsafePatchMapWithMove)-import Data.Map.Monoidal (MonoidalMap)-import Data.Semigroup (Semigroup (..), (<>))---- | A 'Group' is a 'Monoid' where every element has an inverse.-class (Semigroup q, Monoid q) => Group q where- negateG :: q -> q- (~~) :: q -> q -> q- r ~~ s = r <> negateG s---- | An 'Additive' 'Semigroup' is one where (<>) is commutative-class Semigroup q => Additive q where---- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.-newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }--instance Additive p => Patch (AdditivePatch p) where- type PatchTarget (AdditivePatch p) = p- apply (AdditivePatch p) q = Just $ p <> q--instance (Ord k, Group q) => Group (MonoidalMap k q) where- negateG = fmap negateG--instance (Ord k, Additive q) => Additive (MonoidalMap k q)
− src/Reflex/Patch/Class.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--- | The interface for types which represent changes made to other types-module Reflex.Patch.Class where--import Control.Monad.Identity-import Data.Maybe-import Data.Semigroup (Semigroup(..))---- | A 'Patch' type represents a kind of change made to a datastructure.------ If an instance of 'Patch' is also an instance of 'Semigroup', it should obey--- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.-class Patch p where- type PatchTarget p :: *- -- | Apply the patch @p a@ to the value @a@. If no change is needed, return- -- 'Nothing'.- apply :: p -> PatchTarget p -> Maybe (PatchTarget p)---- | Apply a 'Patch'; if it does nothing, return the original value-applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p-applyAlways p t = fromMaybe t $ apply p t---- | 'Identity' can be used as a 'Patch' that always fully replaces the value-instance Patch (Identity a) where- type PatchTarget (Identity a) = a- apply (Identity a) _ = Just a---- | Like '(.)', but composes functions that return patches rather than--- functions that return new values. The Semigroup instance for patches must--- apply patches right-to-left, like '(.)'.-composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p-composePatchFunctions g f a =- let fp = f a- in g (applyAlways fp a) <> fp
− src/Reflex/Patch/DMap.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}--- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.-module Reflex.Patch.DMap where--import Reflex.Patch.Class-import Reflex.Patch.IntMap-import Reflex.Patch.Map--import Data.Dependent.Map (DMap, DSum (..), GCompare (..))-import qualified Data.Dependent.Map as DMap-import Data.Functor.Constant-import Data.Functor.Misc-import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import Data.Semigroup (Semigroup (..))-import Data.Some (Some)---- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.--- Insertions are represented as @'ComposeMaybe' (Just value)@,--- while deletions are represented as @'ComposeMaybe' Nothing@.-newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }--deriving instance GCompare k => Semigroup (PatchDMap k v)--deriving instance GCompare k => Monoid (PatchDMap k v)---- | Apply the insertions or deletions to a given 'DMap'.-instance GCompare k => Patch (PatchDMap k v) where- type PatchTarget (PatchDMap k v) = DMap k v- 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?- where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff- deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff- nothingToJust = \case- Nothing -> Just $ Constant ()- Just _ -> Nothing---- | Map a function @v a -> v' a@ over any inserts/updates in the given--- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.-mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'-mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p---- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given--- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.-traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')-traversePatchDMap f = traversePatchDMapWithKey $ const f---- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates--- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.-traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')-traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p---- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function--- @v a -> v'@ to weaken each value contained in the patch.-weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'-weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p---- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of--- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@.-patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'-patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p---- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.-const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'-const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p- where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')- g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)---- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.-const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f-const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p- where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)- g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)---- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.-getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'-getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
− src/Reflex/Patch/DMapWithMove.hs
@@ -1,363 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}---- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and--- move values between keys.-module Reflex.Patch.DMapWithMove where--import Reflex.Patch.Class-import Reflex.Patch.MapWithMove (PatchMapWithMove (..))-import qualified Reflex.Patch.MapWithMove as MapWithMove--import Data.Constraint.Extras-import Data.Dependent.Map (DMap, DSum (..), GCompare (..))-import qualified Data.Dependent.Map as DMap-import Data.Functor.Constant-import Data.Functor.Misc-import Data.Functor.Product-import Data.GADT.Compare (GEq (..))-import Data.GADT.Show (GShow, gshow)-import qualified Data.Map as Map-import Data.Maybe-import Data.Semigroup (Semigroup (..), (<>))-import Data.Some (Some(Some))-import Data.These---- | 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--- destinations.------ Invariants:------ * A key should not move to itself.--- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)-newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))---- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key--- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.-data NodeInfo k v a = NodeInfo- { _nodeInfo_from :: !(From k v a)- -- ^Change applying to the current key, be it an insert, move, or delete.- , _nodeInfo_to :: !(To k a)- -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.- }- deriving (Show)---- |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--- key (@From_Delete@), or moving a key (@From_Move@).-data From (k :: a -> *) (v :: a -> *) :: a -> * where- -- |Insert a new or update an existing key with the given value @v a@- From_Insert :: v a -> From k v a- -- |Delete the existing key- From_Delete :: From k v a- -- |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@,- -- usually but not necessarily with @From_Delete@.- From_Move :: !(k a) -> From k v a- deriving (Show, Read, Eq, Ord)---- |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--- operation.-type To = ComposeMaybe---- |Test whether a 'PatchDMapWithMove' satisfies its invariants.-validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool-validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove---- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.-validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]-validationErrorsForPatchDMapWithMove m =- noSelfMoves <> movesBalanced- where- noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m- selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"- selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"- selfMove _ = Nothing- movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m- unbalancedMove (dst :=> NodeInfo (From_Move src) _) =- case DMap.lookup src m of- Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"- Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->- if isNothing (dst' `geq` dst)- then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"- else Nothing- _ ->- Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"- unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =- case DMap.lookup dst m of- Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"- Just (NodeInfo (From_Move src') _) ->- if isNothing (src' `geq` src)- then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"- else Nothing-- _ ->- Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"- unbalancedMove _ = Nothing---- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.-instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where- PatchDMapWithMove a == PatchDMapWithMove b = a == b---- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9-data Pair1 f g a = Pair1 (f a) (g a)---- |Helper data structure used for composing patches using the monoid instance.-data Fixup k v a- = Fixup_Delete- | Fixup_Update (These (From k v a) (To k a))---- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@-instance GCompare k => Semigroup (PatchDMapWithMove k v) where- PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m- where- connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb- h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]- h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of- (Just toAfter, From_Move fromBefore)- | isJust $ fromBefore `geq` toAfter- -> [toAfter :=> Fixup_Delete]- | otherwise- -> [ toAfter :=> Fixup_Update (This editBefore)- , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))- ]- (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map- (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]- (Nothing, _) -> []- mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete- mergeFixups _ (Fixup_Update a) (Fixup_Update b)- | This x <- a, That y <- b- = Fixup_Update $ These x y- | That y <- a, This x <- b- = Fixup_Update $ These x y- mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"- fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections- combineNodeInfos _ nia nib = NodeInfo- { _nodeInfo_from = _nodeInfo_from nia- , _nodeInfo_to = _nodeInfo_to nib- }- applyFixup _ ni = \case- Fixup_Delete -> Nothing- Fixup_Update u -> Just $ NodeInfo- { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u- , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u- }- m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups- getHere :: These a b -> Maybe a- getHere = \case- This a -> Just a- These a _ -> Just a- That _ -> Nothing- getThere :: These a b -> Maybe b- getThere = \case- This _ -> Nothing- These _ b -> Just b- That b -> Just b---- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@-instance GCompare k => Monoid (PatchDMapWithMove k v) where- mempty = PatchDMapWithMove mempty- mappend = (<>)--{--mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v-PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src- where- getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself- removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing- removeRedundantDst _ a = Just a- f :: forall a. k a -> From k v a -> Maybe (From k v a)- f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of- From_Move fromKey -> getDstAction fromKey dstBefore- nonMove -> nonMove- dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore- getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m- removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing- removeRedundantSrc _ a = Just a- g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)- g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of- ComposeMaybe Nothing -> ComposeMaybe Nothing- ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter- src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore--}---- |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'.-insertDMapKey :: k a -> v a -> PatchDMapWithMove k v-insertDMapKey k v =- PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)---- |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:------ @--- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))--- @-moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v-moveDMapKey src dst = case src `geq` dst of- Nothing -> PatchDMapWithMove $ DMap.fromList- [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)- , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)- ]- Just _ -> mempty---- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:------ @--- let aMay = DMap.lookup a dmap--- bMay = DMap.lookup b dmap--- in maybe id (DMap.insert a) (bMay `mplus` aMay)--- . maybe id (DMap.insert b) (aMay `mplus` bMay)--- . DMap.delete a . DMap.delete b $ dmap--- @-swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v-swapDMapKey src dst = case src `geq` dst of- Nothing -> PatchDMapWithMove $ DMap.fromList- [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)- , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)- ]- Just _ -> mempty---- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.-deleteDMapKey :: k a -> PatchDMapWithMove k v-deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing--{--k1, k2 :: Const2 Int () ()-k1 = Const2 1-k2 = Const2 2-p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity-p1 = moveDMapKey k1 k2-p2 = moveDMapKey k2 k1-p12 = p1 <> p2-p21 = p2 <> p1-p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2-p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1--testPatchDMapWithMove = do- print p1- print p2- print $ p12 == deleteDMapKey k1- print $ p21 == deleteDMapKey k2- print $ p12Slow == deleteDMapKey k1- print $ p21Slow == deleteDMapKey k2--dst (PatchDMapWithMove x _) = x-src (PatchDMapWithMove _ x) = x--}---- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.-unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)-unPatchDMapWithMove (PatchDMapWithMove p) = p---- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.------ __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.-unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v-unsafePatchDMapWithMove = PatchDMapWithMove---- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned--- otherwise @Left errors@.-patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)-patchDMapWithMove dm =- case validationErrorsForPatchDMapWithMove dm of- [] -> Right $ unsafePatchDMapWithMove dm- errs -> Left errs---- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.-mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'-mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $- DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p- where g :: forall a. From k v a -> From k v' a- g = \case- From_Insert v -> From_Insert $ f v- From_Delete -> From_Delete- From_Move k -> From_Move k---- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.-traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')-traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f---- |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')@.-traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')-traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p- where g :: forall a. k a -> From k v a -> m (From k v' a)- g k = \case- From_Insert v -> From_Insert <$> f k v- From_Delete -> pure From_Delete- From_Move fromKey -> pure $ From_Move fromKey---- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.-nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a-nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }---- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.-nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)-nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni---- |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--- values.-weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'-weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p- where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'- g ni = MapWithMove.NodeInfo- { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of- From_Insert v -> MapWithMove.From_Insert $ f v- From_Delete -> MapWithMove.From_Delete- From_Move k -> MapWithMove.From_Move $ Some k- , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)- }---- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any--- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.-patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'-patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p- where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'- g ni = MapWithMove.NodeInfo- { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of- From_Insert v -> MapWithMove.From_Insert $ f v- From_Delete -> MapWithMove.From_Delete- From_Move (Const2 k) -> MapWithMove.From_Move k- , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)- }---- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed--- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.--- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'-const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'-const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p- where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')- g (k, ni) = Const2 k :=> NodeInfo- { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of- MapWithMove.From_Insert v -> From_Insert $ f v- MapWithMove.From_Delete -> From_Delete- MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey- , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni- }---- | Apply the insertions, deletions, and moves to a given 'DMap'.-instance GCompare k => Patch (PatchDMapWithMove k v) where- type PatchTarget (PatchDMapWithMove k v) = DMap k v- 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?- where insertions = DMap.mapMaybeWithKey insertFunc p- insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)- insertFunc _ ni = case _nodeInfo_from ni of- From_Insert v -> Just v- From_Move k -> DMap.lookup k old- From_Delete -> Nothing- deletions = DMap.mapMaybeWithKey deleteFunc p- deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)- deleteFunc _ ni = case _nodeInfo_from ni of- From_Delete -> Just $ Constant ()- _ -> Nothing---- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.-getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))-getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p- where f _ v ni = Pair v $ _nodeInfo_to ni
− src/Reflex/Patch/IntMap.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}--- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for--- insert/update or delete of associations.-module Reflex.Patch.IntMap where--import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap-import Data.Maybe-import Data.Semigroup-import Reflex.Patch.Class---- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.--- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update--- and @Nothing@ means delete.-newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)---- | Apply the insertions or deletions to a given 'IntMap'.-instance Patch (PatchIntMap a) where- type PatchTarget (PatchIntMap a) = IntMap a- apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $- let removes = IntMap.filter isNothing p- adds = IntMap.mapMaybe id p- in IntMap.union adds $ v `IntMap.difference` removes---- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.--- If the same key is modified by both patches, the one on the left will take--- precedence.-instance Semigroup (PatchIntMap v) where- PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map- -- PatchMap is idempotent, so stimes n is id for every n- stimes = stimesIdempotentMonoid---- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@--- (that is, all inserts/updates), producing a @PatchIntMap b@.-mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b-mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m---- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@--- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.-traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)-traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m---- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.-patchIntMapNewElements :: PatchIntMap a -> [a]-patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m---- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all--- the inserts/updates in the given patch.-patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a-patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m---- | Subset the given @'IntMap' a@ to contain only the keys that would be--- deleted by the given @'PatchIntMap' a@.-getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'-getDeletions (PatchIntMap m) v = IntMap.intersection v m
− src/Reflex/Patch/Map.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeFamilies #-}--- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)--- and deletions-module Reflex.Patch.Map where--import Reflex.Patch.Class--import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Semigroup---- | A set of changes to a 'Map'. Any element may be inserted/updated or--- deleted. Insertions are represented as values wrapped in 'Just', while--- deletions are represented as 'Nothing's-newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }- deriving (Show, Read, Eq, Ord)---- | Apply the insertions or deletions to a given 'Map'.-instance Ord k => Patch (PatchMap k v) where- type PatchTarget (PatchMap k v) = Map k v- {-# INLINABLE apply #-}- apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.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?- where insertions = Map.mapMaybeWithKey (const id) p- deletions = Map.mapMaybeWithKey (const nothingToJust) p- nothingToJust = \case- Nothing -> Just ()- Just _ -> Nothing---- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.--- If the same key is modified by both patches, the one on the left will take--- precedence.-instance Ord k => Semigroup (PatchMap k v) where- PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map- -- PatchMap is idempotent, so stimes n is id for every n- stimes = stimesIdempotentMonoid---- | The empty 'PatchMap' contains no insertions or deletions-instance Ord k => Monoid (PatchMap k v) where- mempty = PatchMap mempty- mappend = (<>)---- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.--- Deletions are unaffected.-instance Functor (PatchMap k) where- fmap f = PatchMap . fmap (fmap f) . unPatchMap---- | Returns all the new elements that will be added to the 'Map'-patchMapNewElements :: PatchMap k v -> [v]-patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p---- | Returns all the new elements that will be added to the 'Map'-patchMapNewElementsMap :: PatchMap k v -> Map k v-patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
− src/Reflex/Patch/MapWithMove.hs
@@ -1,270 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to--- another-module Reflex.Patch.MapWithMove where--import Reflex.Patch.Class--import Control.Arrow-import Control.Monad.State-import Data.Foldable-import Data.Function-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe-import Data.Semigroup (Semigroup (..), (<>))-import qualified Data.Set as Set-import Data.These (These(..))-import Data.Tuple---- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@--- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,--- and vice versa. There should never be any unpaired From/To keys.-newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)---- | Holds the information about each key: where its new value should come from,--- and where its old value should go to-data NodeInfo k v = NodeInfo- { _nodeInfo_from :: !(From k v)- -- ^ Where do we get the new value for this key?- , _nodeInfo_to :: !(To k)- -- ^ If the old value is being kept (i.e. moved rather than deleted or- -- replaced), where is it going?- }- deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)---- | Describe how a key's new value should be produced-data From k v- = From_Insert v -- ^ Insert the given value here- | From_Delete -- ^ Delete the existing value, if any, from here- | From_Move !k -- ^ Move the value here from the given key- deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)---- | Describe where a key's old value will go. If this is 'Just', that means--- the key's old value will be moved to the given other key; if it is 'Nothing',--- that means it will be deleted.-type To = Maybe---- | Create a 'PatchMapWithMove', validating it-patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)-patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing- where valid = forwardLinks == backwardLinks- forwardLinks = Map.mapMaybe _nodeInfo_to m- backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->- case _nodeInfo_from v of- From_Move from -> Just (from, to)- _ -> Nothing---- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'-patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v-patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo- { _nodeInfo_from = From_Insert v- , _nodeInfo_to = Nothing- }---- | Extract the internal representation of the 'PatchMapWithMove'-unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)-unPatchMapWithMove (PatchMapWithMove p) = p---- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.-insertMapKey :: k -> v -> PatchMapWithMove k v-insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing---- |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:------ @--- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))--- @-moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v-moveMapKey src dst- | src == dst = mempty- | otherwise =- PatchMapWithMove $ Map.fromList- [ (dst, NodeInfo (From_Move src) Nothing)- , (src, NodeInfo From_Delete (Just dst))- ]---- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:------ @--- let aMay = Map.lookup a map--- bMay = Map.lookup b map--- in maybe id (Map.insert a) (bMay `mplus` aMay)--- . maybe id (Map.insert b) (aMay `mplus` bMay)--- . Map.delete a . Map.delete b $ map--- @-swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v-swapMapKey src dst- | src == dst = mempty- | otherwise =- PatchMapWithMove $ Map.fromList- [ (dst, NodeInfo (From_Move src) (Just src))- , (src, NodeInfo (From_Move dst) (Just dst))- ]---- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.-deleteMapKey :: k -> PatchMapWithMove k v-deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing---- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.------ __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.-unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v-unsafePatchMapWithMove = PatchMapWithMove---- | Apply the insertions, deletions, and moves to a given 'Map'-instance Ord k => Patch (PatchMapWithMove k v) where- type PatchTarget (PatchMapWithMove k v) = Map k v- apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.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?- where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of- From_Insert v -> Just v- From_Move k -> Map.lookup k old- From_Delete -> Nothing- deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of- From_Delete -> Just ()- _ -> Nothing---- | Returns all the new elements that will be added to the 'Map'.-patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]-patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap---- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.-patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v-patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p- where f ni = case _nodeInfo_from ni of- From_Insert v -> Just v- From_Move _ -> Nothing- From_Delete -> Nothing---- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort--- its values using the given ordering function. The set keys of the 'Map' is--- not changed.-patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v-patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted- where unsorted = Map.toList m- sorted = sortBy (cmp `on` snd) unsorted- f (to, _) (from, _) = if to == from then Nothing else- Just (from, to)- reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted- g (to, _) (from, _) = if to == from then Nothing else- let Just movingTo = Map.lookup to reverseMapping- in Just (to, NodeInfo (From_Move from) $ Just movingTo)---- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,--- will produce a 'Map' with the same values as the second 'Map' but with the--- values sorted with the given ordering function.-patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v-patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex- where newList = Map.toList newByIndexUnsorted- newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList---- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,--- will produce the second 'Map'.-patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v-patchThatChangesMap oldByIndex newByIndex = patch- where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex- (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do- let f k v = do- remainingValues <- get- let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys- then Map.delete v remainingValues- else Map.insert v remainingKeys remainingValues- case Map.lookup v remainingValues of- Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take- Just fromKs ->- if k `Set.member` fromKs- then do- putRemainingKeys $ Set.delete k fromKs- return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary- else do- (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here- putRemainingKeys remainingKeys- return $ NodeInfo (From_Move fromK) $ Just undefined- Map.traverseWithKey f newByIndex- unusedOldKeys = fold unusedValuesByValue- pointlessMove k = \case- From_Move k' | k == k' -> True- _ -> False- keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)- then Just undefined- else Nothing- patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex---- | Change the 'From' value of a 'NodeInfo'-nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v-nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }---- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or--- 'Applicative', 'Monad', etc.) action to get the new value-nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)-nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni---- | Set the 'To' field of a 'NodeInfo'-nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v-nodeInfoSetTo to ni = ni { _nodeInfo_to = to }---- |Helper data structure used for composing patches using the monoid instance.-data Fixup k v- = Fixup_Delete- | Fixup_Update (These (From k v) (To k))---- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@-instance Ord k => Semigroup (PatchMapWithMove k v) where- PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m- where- connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb- h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]- h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of- (Just toAfter, From_Move fromBefore)- | fromBefore == toAfter- -> [(toAfter, Fixup_Delete)]- | otherwise- -> [ (toAfter, Fixup_Update (This editBefore))- , (fromBefore, Fixup_Update (That mToAfter))- ]- (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- (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]- (Nothing, _) -> []- mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete- mergeFixups _ (Fixup_Update a) (Fixup_Update b)- | This x <- a, That y <- b- = Fixup_Update $ These x y- | That y <- a, This x <- b- = Fixup_Update $ These x y- mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"- fixups = Map.fromListWithKey mergeFixups $ concatMap h connections- combineNodeInfos _ nia nib = NodeInfo- { _nodeInfo_from = _nodeInfo_from nia- , _nodeInfo_to = _nodeInfo_to nib- }- applyFixup _ ni = \case- Fixup_Delete -> Nothing- Fixup_Update u -> Just $ NodeInfo- { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u- , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u- }- m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups- getHere :: These a b -> Maybe a- getHere = \case- This a -> Just a- These a _ -> Just a- That _ -> Nothing- getThere :: These a b -> Maybe b- getThere = \case- This _ -> Nothing- These _ b -> Just b- That b -> Just b----TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here--- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@-instance Ord k => Monoid (PatchMapWithMove k v) where- mempty = PatchMapWithMove mempty- mappend = (<>)
src/Reflex/Query/Base.hs view
@@ -16,6 +16,7 @@ , mapQueryResult , dynWithQueryT , withQueryT+ , mapQueryT ) where import Control.Applicative (liftA2)@@ -46,7 +47,7 @@ import Reflex.EventWriter.Base import Reflex.EventWriter.Class import Reflex.Host.Class-import qualified Reflex.Patch.MapWithMove as MapWithMove+import qualified Data.Patch.MapWithMove as MapWithMove import Reflex.PerformEvent.Class import Reflex.PostBuild.Class import Reflex.Query.Class@@ -286,6 +287,10 @@ (fmap (mapQuery f) (sample (currentIncremental q))) (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q) return result++-- | Maps a function over a 'QueryT' that can change the underlying monad+mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a+mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a -- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
src/Reflex/Query/Class.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -21,6 +22,7 @@ , MonadQuery (..) , tellQueryDyn , queryDyn+ , subQuery , mapQuery , mapQueryResult ) where@@ -35,6 +37,9 @@ import qualified Data.Map.Monoidal as MonoidalMap import Data.Semigroup (Semigroup(..)) import Foreign.Storable+import Data.Void+import Data.Monoid hiding ((<>))+import Control.Applicative import Reflex.Class @@ -50,6 +55,37 @@ type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v) crop q r = MonoidalMap.intersectionWith (flip crop) r q +-- | the result of two queries is both results.+instance (Query a, Query b) => Query (a, b) where+ type QueryResult (a, b) = (QueryResult a, QueryResult b)+ crop (x, x') (y, y') = (crop x y, crop x' y')++-- | Trivial queries have trivial results.+instance Query () where+ type QueryResult () = ()+ crop _ _ = ()++-- | The result of an absurd query is trivial; If you can ask the question, the+-- answer cannot tell you anything you didn't already know.+--+-- 'QueryResult Void = @Void@' seems like it would also work, but that has+-- problems of robustness. In some applications, an unasked question can still+-- be answered, so it is important that the result is inhabited even when the+-- question isn't. Applications that wish to prevent this can mandate that the+-- query result be paired with the query: then the whole response will be+-- uninhabited as desired.+instance Query Void where+ type QueryResult Void = ()+ crop = absurd++#if MIN_VERSION_base(4,12,0)+-- | We can lift queries into monoidal containers.+-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)+instance (Query q, Applicative f) => Query (Ap f q) where+ type QueryResult (Ap f q) = Ap f (QueryResult q)+ crop = liftA2 crop+#endif+ -- | QueryMorphism's must be group homomorphisms when acting on the query type -- and compatible with the query relationship when acting on the query result. data QueryMorphism q q' = QueryMorphism@@ -116,3 +152,7 @@ queryDyn q = do tellQueryDyn q zipDynWith crop q <$> askQueryResult++-- | Use a query morphism to operate on a smaller version of a query.+subQuery :: (Reflex t, MonadQuery t q2 m, Monad m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))+subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)
src/Reflex/Spider/Internal.hs view
@@ -38,11 +38,12 @@ import Control.Monad.Exception import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_) import Control.Monad.Primitive---import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) import Control.Monad.Reader.Class import Control.Monad.IO.Class import Control.Monad.ReaderIO import Control.Monad.Ref+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail as MonadFail import Data.Align import Data.Coerce import Data.Dependent.Map (DMap, DSum (..))@@ -59,12 +60,13 @@ import Data.IORef import Data.Kind (Type) import Data.Maybe hiding (mapMaybe)-import Data.Monoid ((<>))+import Data.Monoid (mempty, (<>)) import Data.Proxy import Data.These import Data.Traversable+import Data.Type.Equality ((:~:)(Refl)) import Data.Witherable (Filterable, mapMaybe)-import GHC.Exts+import GHC.Exts hiding (toList) import GHC.IORef (IORef (..)) import GHC.Stack import Reflex.FastWeak@@ -83,14 +85,16 @@ #ifdef DEBUG_CYCLES import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)+#endif+ import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import qualified Data.List.NonEmpty as NonEmpty-import Data.Monoid (mempty) import Data.Tree (Forest, Tree (..), drawForest)-#endif+import Data.List (isPrefixOf) -import Data.FastWeakBag (FastWeakBag)+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket) import qualified Data.FastWeakBag as FastWeakBag+ import Data.Reflection import Data.Some (Some(Some)) import Data.Type.Coercion@@ -101,21 +105,26 @@ import qualified Reflex.Class as R import qualified Reflex.Host.Class import Reflex.NotReady.Class-import Reflex.Patch-import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove+import Data.Patch+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove import Reflex.PerformEvent.Base (PerformEventT) #ifdef DEBUG_TRACE_EVENTS import qualified Data.ByteString.Char8 as BS8 import System.IO (stderr)+import Data.List (isPrefixOf) #endif -#ifdef DEBUG_TRACE_EVENTS+-- TODO stdout might not be the best channel for debug output+debugStrLn :: String -> IO ()+debugStrLn = putStrLn +#ifdef DEBUG_TRACE_EVENTS withStackOneLine :: (BS8.ByteString -> a) -> a withStackOneLine expr = unsafePerformIO $ do stack <- currentCallStack- return (expr (BS8.pack (unwords (reverse stack))))+ return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)+ where dropInternal = filterStack "Reflex.Spider.Internal" #endif @@ -126,28 +135,42 @@ debugInvalidate :: Bool #ifdef DEBUG- #define DEBUG_NODEIDS +#ifdef DEBUG_TRACE_PROPAGATION debugPropagate = True+#else+debugPropagate = False+#endif +#ifdef DEBUG_TRACE_HEIGHT+debugInvalidateHeight = True+#else debugInvalidateHeight = False+#endif +#ifdef DEBUG_TRACE_INVALIDATION debugInvalidate = True+#else+debugInvalidate = False+#endif class HasNodeId a where getNodeId :: a -> Int -instance HasNodeId (Hold x p a) where- getNodeId = holdNodeId+instance HasNodeId (CacheSubscribed x a) where+ getNodeId = _cacheSubscribed_nodeId -instance HasNodeId (PushSubscribed x a b) where- getNodeId = pushSubscribedNodeId+instance HasNodeId (FanInt x a) where+ getNodeId = _fanInt_nodeId +instance HasNodeId (Hold x p) where+ getNodeId = holdNodeId+ instance HasNodeId (SwitchSubscribed x a) where getNodeId = switchSubscribedNodeId -instance HasNodeId (FanSubscribed x a) where+instance HasNodeId (FanSubscribed x v a) where getNodeId = fanSubscribedNodeId instance HasNodeId (CoincidenceSubscribed x a) where@@ -161,41 +184,16 @@ {-# INLINE showNodeId #-} showNodeId :: HasNodeId a => a -> String-showNodeId = ("#"<>) . show . getNodeId+showNodeId = showNodeId' . getNodeId -showSubscriberType :: Subscriber x a -> String-showSubscriberType = \case- SubscriberPush _ _ -> "SubscriberPush"- SubscriberMerge _ _ -> "SubscriberMerge"- SubscriberFan _ -> "SubscriberFan"- SubscriberMergeChange _ -> "SubscriberMergeChange"- SubscriberHold _ -> "SubscriberHold"- SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"- SubscriberSwitch _ -> "SubscriberSwitch"- SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"- SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"- SubscriberHandle -> "SubscriberHandle"+showNodeId' :: Int -> String+showNodeId' = ("#"<>) . show -showEventType :: Event x a -> String-showEventType = \case- EventRoot _ _ -> "EventRoot"- EventNever -> "EventNever"- EventPush _ -> "EventPush"- EventMerge _ -> "EventMerge"- EventFan _ _ -> "EventFan"- EventSwitch _ -> "EventSwitch"- EventCoincidence _ -> "EventCoincidence"- EventHold _ -> "EventHold"- EventDyn _ -> "EventDyn"- EventHoldIdentity _ -> "EventHoldIdentity"- EventDynIdentity _ -> "EventDynIdentity" #else debugPropagate = False- debugInvalidateHeight = False- debugInvalidate = False -- This must be inline, or error messages will cause memory leaks due to retaining the node in question@@ -203,6 +201,10 @@ showNodeId :: a -> String showNodeId _ = "" +{-# INLINE showNodeId' #-}+showNodeId' :: Int -> String+showNodeId' _ = ""+ #endif #ifdef DEBUG_NODEIDS@@ -248,9 +250,9 @@ -- caching; if the computation function is very cheap, this is (much) more -- efficient than 'push' {-# INLINE [1] pushCheap #-}-pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b pushCheap !f e = Event $ \sub -> do- (subscription, occ) <- subscribeAndRead e $ sub+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub { subscriberPropagate = \a -> do mb <- f a mapM_ (subscriberPropagate sub) mb@@ -269,10 +271,10 @@ -- | Subscribe to an Event only for the duration of one occurrence {-# INLINE subscribeAndReadHead #-}-subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)+subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a) subscribeAndReadHead e sub = do subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"- (subscription, occ) <- subscribeAndRead e $ sub+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub { subscriberPropagate = \a -> do liftIO $ unsubscribe =<< readIORef subscriptionRef subscriberPropagate sub a@@ -283,24 +285,29 @@ return (subscription, occ) --TODO: Make this lazy in its input event-headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)+headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a) headE originalE = do parent <- liftIO $ newIORef $ Just originalE defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately let clearParent = liftIO $ writeIORef parent Nothing- (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent when (isJust occ) clearParent- return $ Event $ \sub -> do+ return $ Event $ \sub -> liftIO (readIORef parent) >>= \case- Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)+ Nothing -> subscribeAndReadNever Just e -> subscribeAndReadHead e sub data CacheSubscribed x a = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a)) , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x) , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))+#ifdef DEBUG_NODEIDS+ , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int+#endif } ++ -- | Construct an 'Event' whose value is guaranteed not to be recomputed -- repeatedly --@@ -325,18 +332,23 @@ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case Just subscribedTicket -> return subscribedTicket Nothing -> do+#ifdef DEBUG_NODEIDS+ nodeId <- liftIO newNodeId+#endif subscribers <- liftIO FastWeakBag.empty occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below+#ifdef DEBUG_NODEIDS+ (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber+#else (parentSub, occ) <- subscribeAndRead e $ Subscriber- { subscriberPropagate = \a -> do- liftIO $ writeIORef occRef $ Just a- scheduleClear occRef- propagateFast a subscribers- , subscriberInvalidateHeight = \old -> do- FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old- , subscriberRecalculateHeight = \new -> do- FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new- }+#endif+ { subscriberPropagate = \a -> do+ liftIO $ writeIORef occRef (Just a)+ scheduleClear occRef+ propagateFast a subscribers+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight+ } when (isJust occ) $ do liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing scheduleClear occRef@@ -344,30 +356,46 @@ { _cacheSubscribed_subscribers = subscribers , _cacheSubscribed_parent = parentSub , _cacheSubscribed_occurrence = occRef+#ifdef DEBUG_NODEIDS+ , _cacheSubscribed_nodeId = nodeId+#endif } subscribedTicket <- liftIO $ mkFastWeakTicket subscribed liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket return subscribedTicket- liftIO $ do- subscribed <- getFastWeakTicketValue subscribedTicket- ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed- occ <- readIORef $ _cacheSubscribed_occurrence subscribed- let es = EventSubscription- { _eventSubscription_unsubscribe = do- FastWeakBag.remove ticket- isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed- when isEmpty $ do- writeIORef mSubscribedRef emptyFastWeak- unsubscribe $ _cacheSubscribed_parent subscribed- touch ticket- touch subscribedTicket- , _eventSubscription_subscribed = EventSubscribed- { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed- , eventSubscribedRetained = toAny subscribedTicket- }- }- return (es, occ)+ liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket +cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))+ -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)+cacheSubscription sub mSubscribedRef subscribedTicket = do+ subscribed <- getFastWeakTicketValue subscribedTicket+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed++ let parentSub = _cacheSubscribed_parent subscribed+ es = EventSubscription+ { _eventSubscription_unsubscribe = do+ FastWeakBag.remove ticket++ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed+ when isEmpty $ do+ writeIORef mSubscribedRef emptyFastWeak+ unsubscribe parentSub+ touch ticket+ touch subscribedTicket+ , _eventSubscription_subscribed = EventSubscribed+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub+ , eventSubscribedRetained = toAny subscribedTicket+#ifdef DEBUG_CYCLES+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]+ , eventSubscribedHasOwnHeightRef = False+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef+#endif+ }+ }+ return (es, occ)++ subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x) subscribe e s = fst <$> subscribeAndRead e s @@ -378,11 +406,14 @@ let es = tag subd return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ) -eventRoot :: GCompare k => k a -> Root x k -> Event x a+eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r +subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)+ eventNever :: Event x a-eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)+eventNever = Event $ const subscribeAndReadNever eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a) eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f@@ -437,10 +468,10 @@ } newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))-newSubscriberFan subscribed = return $ Subscriber+newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed- tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"+ tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing" liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a scheduleClear $ fanSubscribedOccurrence subscribed let f _ (Pair v subsubs) = do@@ -449,50 +480,40 @@ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_ return () , subscriberInvalidateHeight = \old -> do- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed subscribers <- readIORef $ fanSubscribedSubscribers subscribed forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" , subscriberRecalculateHeight = \new -> do- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed subscribers <- readIORef $ fanSubscribedSubscribers subscribed forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" } newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)-newSubscriberSwitch subscribed = return $ Subscriber+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do- tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a scheduleClear $ switchSubscribedOccurrence subscribed propagate a $ switchSubscribedSubscribers subscribed , subscriberInvalidateHeight = \_ -> do- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed oldHeight <- readIORef $ switchSubscribedHeight subscribed when (oldHeight /= invalidHeight) $ do writeIORef (switchSubscribedHeight subscribed) $! invalidHeight WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"- , subscriberRecalculateHeight = \new -> do- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed- updateSwitchHeight new subscribed- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"- }+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)+ } newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))-newSubscriberCoincidenceOuter subscribed = return $ Subscriber+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do- tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ) tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd scheduleClear $ coincidenceSubscribedInnerParent subscribed case occ of- Nothing -> do+ Nothing -> when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight@@ -501,20 +522,13 @@ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ scheduleClear $ coincidenceSubscribedOccurrence subscribed propagate o $ coincidenceSubscribedSubscribers subscribed- , subscriberInvalidateHeight = \_ -> do- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed- invalidateCoincidenceHeight subscribed- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"- , subscriberRecalculateHeight = \_ -> do- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed- recalculateCoincidenceHeight subscribed- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed } newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)-newSubscriberCoincidenceInner subscribed = return $ Subscriber+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do- tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed case occ of Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event@@ -522,14 +536,8 @@ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a scheduleClear $ coincidenceSubscribedOccurrence subscribed propagate a $ coincidenceSubscribedSubscribers subscribed- , subscriberInvalidateHeight = \_ -> do- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed- invalidateCoincidenceHeight subscribed- when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"- , subscriberRecalculateHeight = \_ -> do- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed- recalculateCoincidenceHeight subscribed- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed } invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()@@ -539,15 +547,15 @@ recalculateSubscriberHeight = flip subscriberRecalculateHeight -- | Propagate everything at the current height-propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()-propagate a subscribers = withIncreasedDepth $ do+propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a -- | Propagate everything at the current height-propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()-propagateFast a subscribers = withIncreasedDepth $ do+propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a@@ -568,7 +576,7 @@ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height) , eventSubscribedRetained :: {-# NOUNPACK #-} !Any #ifdef DEBUG_CYCLES- , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops , eventSubscribedHasOwnHeightRef :: !Bool , eventSubscribedWhoCreated :: !(IO [String]) #endif@@ -601,7 +609,7 @@ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed , eventSubscribedRetained = toAny subscribed #ifdef DEBUG_CYCLES- , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed] , eventSubscribedHasOwnHeightRef = False , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed #endif@@ -614,7 +622,7 @@ #ifdef DEBUG_CYCLES , eventSubscribedGetParents = do s <- readIORef $ switchSubscribedCurrentParent subscribed- return [Some $ _eventSubscription_subscribed s]+ return [_eventSubscription_subscribed s] , eventSubscribedHasOwnHeightRef = True , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed #endif@@ -627,8 +635,8 @@ #ifdef DEBUG_CYCLES , eventSubscribedGetParents = do innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed- let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed- innerParents = maybeToList $ fmap Some innerSubscription+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed+ innerParents = maybeToList $ innerSubscription return $ outerParent : innerParents , eventSubscribedHasOwnHeightRef = True , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed@@ -642,15 +650,15 @@ whoCreatedEventSubscribed :: EventSubscribed x -> IO [String] whoCreatedEventSubscribed = eventSubscribedWhoCreated -walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x] walkInvalidHeightParents s0 = do- subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do h <- liftIO $ readIORef $ eventSubscribedHeightRef s when (h == invalidHeight) $ do when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed- modify (Some s :)+ modify (s :) mapM_ loop =<< liftIO (eventSubscribedGetParents s)- forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight return subscribers #endif @@ -972,8 +980,10 @@ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y {-# INLINE return #-} return x = BehaviorM $ return x+#if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail s = BehaviorM $ fail s+#endif data BehaviorSubscribed x a = forall p. BehaviorSubscribedHold (Hold x p)@@ -1033,7 +1043,7 @@ newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () } -- EventM can do everything BehaviorM can, plus create holds-newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x } @@ -1058,7 +1068,8 @@ heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights heightBagAdd :: Height -> HeightBag -> HeightBag-heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $+ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c heightBagRemove :: Height -> HeightBag -> HeightBag heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of@@ -1067,6 +1078,13 @@ 0 -> IntMap.delete h c _ -> IntMap.insert h (pred old) c +heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag+heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where+ removed old = HeightBag (pred s) $ case old of+ 0 -> IntMap.delete h c+ _ -> IntMap.insert h (pred old) c++ heightBagMax :: HeightBag -> Height heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of Just ((h, _), _) -> Height h@@ -1314,55 +1332,110 @@ x' <- evaluate x mkWeakPtr x' $ if debugFinalize- then Just $ putStrLn $ "finalizing: " ++ debugNote+ then Just $ debugStrLn $ "finalizing: " ++ debugNote else Nothing type WeakList a = [Weak a] -{-# INLINE withIncreasedDepth #-}+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)++++ #ifdef DEBUG-withIncreasedDepth :: CanTrace x m => m a -> m a-withIncreasedDepth a = do- spiderTimeline <- askSpiderTimelineEnv- liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ++debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)+debugSubscriber description = return . debugSubscriber' description++debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a+debugSubscriber' description subscribed = Subscriber+ {+ subscriberPropagate = \m -> do+ tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)+ subscriberPropagate subscribed m+ , subscriberInvalidateHeight = \old -> do+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)+ subscriberInvalidateHeight subscribed old+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"+ , subscriberRecalculateHeight = \new -> do+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)+ subscriberRecalculateHeight subscribed new+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"+ }+++{-# INLINE withIncreasedDepth #-}+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a+withIncreasedDepth _ a = do+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ result <- a- liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred return result-#else-withIncreasedDepth :: m a -> m a-withIncreasedDepth = id-#endif -type CanTrace x m = (HasSpiderTimeline x, MonadIO m)- {-# INLINE tracePropagate #-} tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()-tracePropagate p = traceWhen p debugPropagate+tracePropagate p = when debugPropagate . trace p {-# INLINE traceInvalidate #-} traceInvalidate :: String -> IO ()-traceInvalidate = when debugInvalidate . liftIO . putStrLn+traceInvalidate = when debugInvalidate . liftIO . debugStrLn -{-# INLINE traceWhen #-}-traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()-traceWhen p b message = traceMWhen p b $ return message+{-# INLINE traceInvalidateHeight #-}+traceInvalidateHeight :: String -> IO ()+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn -{-# INLINE traceMWhen #-}-traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()-traceMWhen _ b getMessage = when b $ do+{-# INLINE trace #-}+trace :: (CanTrace x m) => proxy x -> String -> m ()+trace p message = traceM p $ return message++{-# INLINE traceM #-}+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()+traceM _ getMessage = do message <- getMessage-#ifdef DEBUG- spiderTimeline <- askSpiderTimelineEnv- d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)+ liftIO $ debugStrLn $ replicate d ' ' <> message+ #else- let d = 0++{-# INLINE withIncreasedDepth #-}+withIncreasedDepth :: proxy x -> m a -> m a+withIncreasedDepth _ = id++{-# INLINE tracePropagate #-}+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()+tracePropagate _ _ = return ()++{-# INLINE traceInvalidate #-}+traceInvalidate :: String -> IO ()+traceInvalidate _ = return ()++{-# INLINE traceInvalidateHeight #-}+traceInvalidateHeight :: String -> IO ()+traceInvalidateHeight _ = return ()++{-# INLINE debugSubscriber #-}+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)+debugSubscriber _ = return++{-# INLINE debugSubscriber' #-}+debugSubscriber' :: String -> Subscriber x a -> Subscriber x a+debugSubscriber' _ = id++++{-# INLINE trace #-}+trace :: (CanTrace x m) => proxy x -> String -> m ()+trace _ _ = return ()++{-# INLINE traceM #-}+traceM :: (CanTrace x m) => proxy x -> m String -> m ()+traceM _ _ = return ()+ #endif- liftIO $ putStrLn $ replicate d ' ' <> message whoCreatedIORef :: IORef a -> IO [String] whoCreatedIORef (IORef a) = whoCreated $! a -#ifdef DEBUG_CYCLES groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])] groupByHead = \case [] -> []@@ -1373,20 +1446,54 @@ | otherwise -> (x, xs :| []) : l listsToForest :: Eq a => [[a]] -> Forest a-listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l+listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)+ where buildForest (a, lists') = Node a $ listsToForest $ toList lists'++showStacks :: [[String]] -> String+showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")++filterStack :: String -> [String] -> [String]+#ifdef DEBUG_HIDE_INTERNALS+filterStack prefix = filter (not . (prefix `isPrefixOf`))+#else+filterStack prefix = id #endif +#ifdef DEBUG_CYCLES++data EventLoopException = EventLoopException [[String]]+instance Exception EventLoopException++instance Show EventLoopException where+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks+ then "no location information, compile with profiling enabled for stack tree"+ else showStacks stacks++#else++data EventLoopException = EventLoopException+instance Exception EventLoopException++instance Show EventLoopException where+ show EventLoopException = "causality loop detected: \n" <>+ "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"++#endif++ {-# INLINE propagateSubscriberHold #-} propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x () propagateSubscriberHold h a = do- {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do invalidators <- liftIO $ readIORef $ holdInvalidators h return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h case {-# SCC "apply" #-} apply a v of Nothing -> return () Just v' -> do- {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h) vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'@@ -1440,7 +1547,7 @@ zeroRef :: IORef Height zeroRef = unsafePerformIO $ newIORef zeroHeight -getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)+getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a) getRootSubscribed k r sub = do mSubscribed <- readIORef $ rootSubscribed r let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r@@ -1454,7 +1561,9 @@ let !cached = rootSubscribed r uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized" (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed- when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"++ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k) writeIORef uninitRef $! uninit #ifdef DEBUG_NODEIDS@@ -1504,6 +1613,9 @@ { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))+#ifdef DEBUG_NODEIDS+ , _fanInt_nodeId :: {-# UNPACK #-} !Int+#endif } newFanInt :: IO (FanInt x a)@@ -1511,10 +1623,16 @@ subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty subscriptionRef <- newIORef $ error "fanInt: no subscription" occRef <- newIORef $ error "fanInt: no occurrence"+#ifdef DEBUG_NODEIDS+ nodeId <- newNodeId+#endif return $ FanInt { _fanInt_subscribers = subscribers , _fanInt_subscriptionRef = subscriptionRef , _fanInt_occRef = occRef+#ifdef DEBUG_NODEIDS+ , _fanInt_nodeId = nodeId+#endif } fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a@@ -1523,20 +1641,21 @@ pure $ EventSelectorInt $ \k -> Event $ \sub -> do isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self) when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input- (subscription, parentOcc) <- subscribeAndRead p $ Subscriber+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber { subscriberPropagate = \m -> do liftIO $ writeIORef (_fanInt_occRef self) m scheduleIntClear $ _fanInt_occRef self- FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?- FastWeakBag.traverse_ b $ \s -> do+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?+ FastWeakBag.traverse_ b $ \s -> subscriberPropagate s v- , subscriberInvalidateHeight = \old -> do- FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do- FastWeakBag.traverse_ b $ \s -> do+ , subscriberInvalidateHeight = \old ->+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->+ FastWeakBag.traverse_ b $ \s -> subscriberInvalidateHeight s old- , subscriberRecalculateHeight = \new -> do- FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do- FastWeakBag.traverse_ b $ \s -> do+ , subscriberRecalculateHeight = \new ->+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->+ FastWeakBag.traverse_ b $ \s -> subscriberRecalculateHeight s new } liftIO $ do@@ -1550,11 +1669,26 @@ FastMutableIntMap.insert (_fanInt_subscribers self) k b return b Just b -> return b- t <- liftIO $ FastWeakBag.insert sub b+ ticket <- liftIO $ FastWeakBag.insert sub b currentOcc <- readIORef (_fanInt_occRef self)- (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)- return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc) + subscribed <- fanIntSubscribed ticket self+ return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)++fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)+fanIntSubscribed ticket self = do+ subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)+ return $ EventSubscribed+ { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent+ , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)+#ifdef DEBUG_CYCLES+ , eventSubscribedGetParents = return [subscribedParent]+ , eventSubscribedHasOwnHeightRef = False+ , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self+#endif+ }++ {-# INLINABLE getFanSubscribed #-} getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a)) getFanSubscribed k f sub = do@@ -1751,7 +1885,7 @@ => (forall a. q a -> Event x (v a)) -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)-mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy where updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x) updateMe subscriber heightBagRef oldParents (PatchDMap p) = do@@ -1766,7 +1900,9 @@ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps forM_ mOldSubd $ \oldSubd -> do- oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd+ oldHeight <- liftIO $ getEventSubscribedHeight $+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs) foldM f ([], oldParents) $ DMap.toList p@@ -1791,7 +1927,7 @@ => (forall a. q a -> Event x (v a)) -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)-mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy where updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k) updateMe subscriber heightBagRef oldParents p = do@@ -1810,13 +1946,17 @@ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of Nothing -> do- oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $+ _mergeSubscribedParentWithMove_subscription parent+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight return $ Just $ _mergeSubscribedParentWithMove_subscription parent Just toKey -> do liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey return Nothing- toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents+ return (toDelete, applyAlways p' oldParents) getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k) getInitialSubscribers initialParents subscriber = do@@ -1841,6 +1981,8 @@ -> p -> EventM x ([EventSubscription x], DMap k s) +type MergeGetSubscription x s = forall a. s a -> EventSubscription x+ type MergeInitFunc k v q x s = DMap k q -> (forall a. EventM x (k a) -> Subscriber x (v a))@@ -1864,14 +2006,17 @@ invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO () invalidateMergeHeight' heightRef sub = do oldHeight <- readIORef heightRef- when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents+ when (oldHeight /= invalidHeight) $ do writeIORef heightRef $! invalidHeight subscriberInvalidateHeight sub oldHeight revalidateMergeHeight :: Merge x k v s -> IO () revalidateMergeHeight m = do currentHeight <- readIORef $ _merge_heightRef m- when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check++ -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check+ when (currentHeight == invalidHeight) $ do heights <- readIORef $ _merge_heightBagRef m parents <- readIORef $ _merge_parentsRef m -- When the number of heights in the bag reaches the number of parents, we should have a valid height@@ -1879,7 +2024,7 @@ LT -> return () EQ -> do let height = succHeight $ heightBagMax heights- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height writeIORef (_merge_heightRef m) $! height subscriberRecalculateHeight (_merge_sub m) height GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"@@ -1887,36 +2032,45 @@ scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x () scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do vals <- liftIO $ readIORef $ _merge_accumRef m- liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,+ -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty --TODO: Assert that m is not empty subscriberPropagate (_merge_sub m) vals -mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)-mergeSubscriber m getKey = Subscriber+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()+checkCycle subscribed = liftIO $ do+ height <- readIORef (eventSubscribedHeightRef subscribed)++ -- currentHeight <- getCurrentHeight+ -- when (height <= currentHeight) $ if height /= invalidHeight+ -- then do+ -- myStack <- liftIO $ whoCreatedIORef undefined --TODO+ -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)+ -- else liftIO $+ when (height == invalidHeight) $+#ifdef DEBUG_CYCLES+ do+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed+ throwIO (EventLoopException stacks)+#else+ throwIO EventLoopException+#endif+++mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)+mergeSubscriber subscribed m getKey = Subscriber { subscriberPropagate = \a -> do oldM <- liftIO $ readIORef $ _merge_accumRef m k <- getKey- let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM) liftIO $ writeIORef (_merge_accumRef m) $! newM when (DMap.null oldM) $ do -- Only schedule the firing once height <- liftIO $ readIORef $ _merge_heightRef m- --TODO: assertions about height- currentHeight <- getCurrentHeight- when (height <= currentHeight) $ do- if height /= invalidHeight- then do- myStack <- liftIO $ whoCreatedIORef undefined --TODO- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)- else liftIO $ do-#ifdef DEBUG_CYCLES- nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed- stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es- let cycleInfo = ":\n" <> drawForest (listsToForest stacks)-#else- let cycleInfo = ""-#endif- error $ "Causality loop found" <> cycleInfo+ checkCycle subscribed+ scheduleMergeSelf m height , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old@@ -1927,31 +2081,45 @@ } --TODO: Be able to run as much of this as possible promptly-updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x-updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)+updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m) where updateMe = do oldParents <- liftIO $ readIORef $ _merge_parentsRef m- (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p liftIO $ writeIORef (_merge_parentsRef m) $! newParents return subscriptionsToKill {-# INLINE mergeGCheap' #-} mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)- => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)-mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do+ => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized" heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized" parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"- let m = Merge+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"++ let subscribed = EventSubscribed+ { eventSubscribedHeightRef = heightRef+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)+#ifdef DEBUG_CYCLES+ , eventSubscribedGetParents = do+ let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)+ fmap getParent' . DMap.toList <$> readIORef parentsRef+ , eventSubscribedHasOwnHeightRef = False+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef+#endif+ }++ m = Merge { _merge_parentsRef = parentsRef , _merge_heightBagRef = heightBagRef , _merge_heightRef = heightRef , _merge_sub = sub , _merge_accumRef = accumRef }- (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights myHeight = if invalidHeight `elem` heights then invalidHeight@@ -1960,32 +2128,30 @@ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now then (if DMap.null dm then Nothing else Just dm, DMap.empty) else (Nothing, dm)- unless (DMap.null accum) $ do- scheduleMergeSelf m myHeight+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight liftIO $ writeIORef accumRef $! accum liftIO $ writeIORef heightRef $! myHeight liftIO $ writeIORef heightBagRef $! myHeightBag- changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized" liftIO $ writeIORef parentsRef $! initialParentState defer $ SomeMergeInit $ do- let s = Subscriber+ let changeSubscriber = Subscriber { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do- tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"- defer $ updateMerge m updateFunc a+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"+ defer $ updateMerge subscribed m updateFunc a , subscriberInvalidateHeight = \_ -> return () , subscriberRecalculateHeight = \_ -> return () }- (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s- forM_ change $ \c -> defer $ updateMerge m updateFunc c+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c -- We explicitly hold on to the unsubscribe function from subscribing to the update event. -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain -- its subscription.- liftIO $ writeIORef changeSubdRef (s, changeSubscription)+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription) let unsubscribeAll = destroy =<< readIORef parentsRef- return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)- , occ- ) + return (EventSubscription unsubscribeAll subscribed, occ)++ mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a) mergeInt = cacheEvent . mergeIntCheap @@ -1997,13 +2163,22 @@ heightRef <- liftIO $ newIORef zeroHeight heightBagRef <- liftIO $ newIORef heightBagEmpty parents <- liftIO $ FastMutableIntMap.newEmpty+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"+ let subscribed = EventSubscribed+ { eventSubscribedHeightRef = heightRef+ , eventSubscribedRetained = toAny (parents, changeSubdRef)+#ifdef DEBUG_CYCLES+ , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents+ , eventSubscribedHasOwnHeightRef = False+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef+#endif+ } let scheduleSelf = do height <- liftIO $ readIORef $ heightRef scheduleMerge' height heightRef $ do vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum subscriberPropagate sub vals- invalidateMyHeight = do- invalidateMergeHeight' heightRef sub+ invalidateMyHeight = invalidateMergeHeight' heightRef sub recalculateMyHeight = do currentHeight <- readIORef heightRef when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?@@ -2013,12 +2188,14 @@ LT -> return () EQ -> do let height = succHeight $ heightBagMax heights- when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height writeIORef heightRef $! height subscriberRecalculateHeight sub height GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge" mySubscriber k = Subscriber { subscriberPropagate = \a -> do+ checkCycle subscribed+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum liftIO $ FastMutableIntMap.insert accum k a when wasEmpty scheduleSelf@@ -2052,7 +2229,6 @@ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet return Nothing- changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized" defer $ SomeMergeInit $ do let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight where@@ -2066,26 +2242,28 @@ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions liftIO $ for_ oldParents $ \oldParent -> do oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent++ print ("updateMe", oldParentHeight) modifyIORef' heightBagRef $ heightBagRemove oldParentHeight return $ IntMap.elems oldParents- let s = Subscriber+ let changeSubscriber = Subscriber { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change" defer $ updateMe a , subscriberInvalidateHeight = \_ -> return () , subscriberRecalculateHeight = \_ -> return () }- (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber forM_ change $ \c -> defer $ updateMe c -- We explicitly hold on to the unsubscribe function from subscribing to the update event. -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain -- its subscription.- liftIO $ writeIORef changeSubdRef (s, changeSubscription)+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription) let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents- return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)- , occ- ) ++ return (EventSubscription unsubscribeAll subscribed, occ)+ newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a } newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) } @@ -2167,19 +2345,19 @@ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do writeIORef vRef v- when debugInvalidate $ putStrLn $ "Invalidating Hold"+ traceInvalidate $ "Invalidating Hold" writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef mergeUpdates <- readIORef $ eventEnvMergeUpdates env writeIORef (eventEnvMergeUpdates env) []- when debugPropagate $ putStrLn "Updating merges"+ tracePropagate (Proxy::Proxy x) $ "Updating merges" mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates- when debugPropagate $ putStrLn "Updating merges done"+ tracePropagate (Proxy::Proxy x) $ "Updating merges done" toReconnect <- readIORef toReconnectRef clearEventEnv env switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed- when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed finalize wi i <- evaluate $ switchSubscribedOwnInvalidator subscribed wi' <- mkWeakPtrWithDebug i "wi'"@@ -2193,7 +2371,7 @@ 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 {- stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)- liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of EventRoot _ -> "EventRoot" EventNever -> "EventNever" _ -> "something else"@@ -2357,8 +2535,10 @@ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x {-# INLINE (>>) #-} (>>) = (*>)+#if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail _ = error "Dynamic does not support 'fail'"+#endif {-# INLINABLE newJoinDyn #-} newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)@@ -2483,13 +2663,13 @@ touch h return result -instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO newFanEventWithTrigger f = SpiderHost $ do es <- newFanEventWithTriggerIO f return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es -instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do es <- newFanEventWithTriggerIO f@@ -2637,9 +2817,15 @@ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y {-# INLINABLE return #-} return x = SpiderHost $ return x+#if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-}- fail s = SpiderHost $ fail s+ fail = MonadFail.fail+#endif +instance MonadFail (SpiderHost x) where+ {-# INLINABLE fail #-}+ fail s = SpiderHost $ MonadFail.fail s+ -- | Run an action affecting the global Spider timeline; this will be guarded by -- a mutex for that timeline runSpiderHost :: SpiderHost Global a -> IO a@@ -2660,19 +2846,21 @@ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y {-# INLINABLE return #-} return x = SpiderHostFrame $ return x+#if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} fail s = SpiderHostFrame $ fail s+#endif instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where notReadyUntil _ = pure () notReady = pure () -newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)+newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a) newEventWithTriggerIO f = do es <- newFanEventWithTriggerIO $ \Refl -> f return $ select es Refl -newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)+newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k) newFanEventWithTriggerIO f = do occRef <- newIORef DMap.empty subscribedRef <- newIORef DMap.empty
src/Reflex/Widget/Basic.hs view
@@ -13,7 +13,7 @@ import Reflex.Class import Reflex.Adjustable.Class-import Reflex.Patch.MapWithMove+import Data.Patch.MapWithMove -- | Build sortable content in such a way that re-sorting it can cause minimal
+ test/Adjustable.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}++module Main where++import Control.Monad.Fix+import Data.Maybe+import qualified Data.Map as Map++import Reflex+import Reflex.EventWriter.Base+import Reflex.Network+import Reflex.Patch.MapWithMove+import Test.Run++main :: IO ()+main = do+ let actions = [ Increment, Update0th, Increment, Swap, Increment, Increment ]+ os <- runAppB testPatchMapWithMove $ map Just actions+ -- If the final counter value in the adjusted widgets corresponds to the number of times it has+ -- been incremented, we know that the networks haven't broken.+ let expectedCount = length $ ffilter (== Increment) actions+ -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved+ return ()++data PatchMapTestAction+ = Increment+ | Swap+ | Update0th+ deriving Eq++-- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing.+testPatchMapWithMove+ :: forall t m+ . ( Reflex t+ , Adjustable t m+ , MonadHold t m+ , MonadFix m+ )+ => Event t PatchMapTestAction+ -> m (Behavior t [Int])+testPatchMapWithMove pulse = do+ let pulseAction = ffor pulse $ \case+ Increment -> Nothing+ Swap -> patchMapWithMove $ Map.fromList+ [ (0, NodeInfo (From_Move 1) (Just 1))+ , (1, NodeInfo (From_Move 0) (Just 0))+ ]+ Update0th -> patchMapWithMove $ Map.fromList+ [ (0, NodeInfo (From_Insert 'z') Nothing) ]+ (_, result) <- runBehaviorWriterT $ mdo+ counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction+ _ <- mapMapWithAdjustWithMove+ (\_ _ -> networkHold+ (tellBehavior $ constant [])+ ((\t -> tellBehavior $ constant [t]) <$> updated counter))+ (Map.fromList $ zip [0..] "ab")+ (fmapMaybe id pulseAction)+ return ()+ return result
+ test/DebugCycles.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}++module Main where++import Data.Foldable+import Control.Lens+import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Exception+import System.Timeout+import Data.Maybe (isJust)+import Data.Functor.Misc+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.These+import Data.Align+import Reflex+import Reflex.EventWriter.Base+import Test.Run+import Test.Hspec+import Reflex.Spider.Internal (EventLoopException)+import Data.Witherable (Filterable)++#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))+import Data.These.Lens+#endif++type Widget t m = (MonadHold t m, Reflex t, MonadFix m)++connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)+connectDyn e (d, d') = do+ dd <- holdDyn d (d' <$ e)+ return $ join dd++dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+dynLoop (e1, e2) = do+ -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"+ rec+ d <- count e1+ d' <- connectDyn e2 (d, liftA2 (+) d d')+ return $ updated d'++connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)+connectOnCoincidence click e = do+ d <- holdDyn never (e <$ click)+ return $ coincidence (updated d)++coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+coincidenceLoop (e1, e2) = do+-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"+-- (simpler version of dynLoop)+ rec+ e' <- connectOnCoincidence e2 (updated d)+ d <- count (align e' e1)+ return $ updated d++addHeight :: Reflex t => Event t a -> Event t a+addHeight e = leftmost [e4, e4] where+ e1 = leftmost [e, e]+ e2 = leftmost [e1, e1]+ e3 = leftmost [e2, e2]+ e4 = leftmost [e3, e3]++-- Take an existing test and build it inside a+buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)+buildLoop test (e1, e2) = switchHold never buildLoop+ where buildLoop = pushAlways (const $ test (e1, e2)) e2++connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)+connectButtonPromptly click e = do+ d <- holdDyn never (e <$ click)+ return (switchDyn d)++connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)+connectButton click e = do+ d <- hold never (e <$ click)+ return (switch d)++switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+switchLoop01 (e1, e2) = do+ rec+ e' <- connectButton e2 (updated d)+ d <- count (align e' e1)+ return $ updated d++mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)+mergeLoop (e1, e2) = do+ rec+ (_, e) <- runEventWriterT $+ runWithReplace w (leftmost [w <$ e1])+ return (sum <$> e)+ where+ w = do+ c <- count e1+ tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))++switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+switchLoop02 (e1, e2) = do+ rec+ e' <- connectButton e2 (updated d)+ d <- count (leftmost [e', e1])+ return $ updated d++switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+switchLoop03 (e1, e2) = do+ rec+ e' <- connectButton e2 (addHeight $ updated d)+ d <- count (align e' e1)+ return $ updated d++staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+staticLoop01 (e1, e2) = do+ rec+ d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))+ return $ updated d++staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+staticLoop02 (e1, e2) = do+ rec+ d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])+ return $ updated d++buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)+buildStaticLoop (e1, e2) = switchHold never buildLoop+ where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2++splitThese :: Filterable f => f (These a b) -> (f a, f b)+splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)++main :: IO ()+main = hspec $ do+ describe "DebugCycles" $ do+ it "throws EventLoopException on switchLoop01" $ do+ check switchLoop01+ it "throws EventLoopException on switchLoop02" $ do+ check switchLoop02+ it "throws EventLoopException on switchLoop03" $ do+ check switchLoop03+ it "throws EventLoopException on buildSwitchLoop" $ do+ check $ buildLoop switchLoop01+ xit "throws EventLoopException on mergeLoop" $ do+ check mergeLoop+ xit "throws EventLoopException on staticLoop01" $ do+ check staticLoop01+ xit "throws EventLoopException on staticLoop02" $ do+ check staticLoop02+ xit "throws EventLoopException on buildStaticLoop" $ do+ check buildStaticLoop+ xit "throws EventLoopException on coincidenceLoop" $ do+ check coincidenceLoop+ xit "throws EventLoopException on dynLoop" $ do+ check dynLoop+ xit "throws EventLoopException on buildCoincidenceLoop" $ do+ check $ buildLoop coincidenceLoop+ where+ milliseconds = (*1000)+ occs = [ This 1, This 2, That (), This 3, That (), This 1 ]+ check test = do+ let action = timeout (milliseconds 50) $ do+ runApp' (test . splitThese) (Just <$> occs)+ action `shouldThrow` (const True :: Selector EventLoopException)
test/GC.hs view
@@ -20,7 +20,7 @@ import Data.These import Data.Functor.Misc-import Reflex.Patch+import Data.Patch import qualified Reflex.Host.Class as Host import qualified Reflex.Spider.Internal as S@@ -83,7 +83,6 @@ Nothing -> [] Host.fireEventsAndRead followupEventTriggers $ return () return ()- return () data Tell a where Action :: Tell ()
test/QueryT.hs view
@@ -24,7 +24,7 @@ #endif import Reflex-import Reflex.Patch.MapWithMove+import Data.Patch.MapWithMove import Test.Run newtype MyQuery = MyQuery SelectedCount
test/RequesterT.hs view
@@ -1,20 +1,36 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} module Main where -import Control.Lens+import Control.Lens hiding (has) import Control.Monad import Control.Monad.Fix+import Control.Monad.IO.Class (MonadIO)+import Data.Constraint.Extras+import Data.Constraint.Extras.TH+import Data.Constraint.Forall import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Functor.Misc+import Data.List (words)+import Data.Map (Map) import qualified Data.Map as M+#if !MIN_VERSION_these(4,11,0)+import Data.Semigroup ((<>))+#endif+import Data.Text (Text) import Data.These+import Text.Read (readMaybe) #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) import Data.These.Lens@@ -49,12 +65,19 @@ print os5 os6 <- runApp' (unwrapApp delayedPulse) [Just ()] print os6+ os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]+ print os7+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]+ print os8 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT' let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2 let ![[Nothing, Just [2]]] = os3 let ![[Nothing, Just [2]]] = os4 let ![[Nothing, Just [1, 2]]] = os5 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved+ let !(Just [(1,"2")]) = M.toList <$> head (head os7)+ let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)+ return () unwrapRequest :: DSum tag RequestInt -> Int@@ -172,3 +195,41 @@ -- This has the effect of delaying pulse' from pulse (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse requestingIdentity pulse'++data TestRequest a where+ TestRequest_Reverse :: String -> TestRequest String+ TestRequest_Increment :: Int -> TestRequest Int++testMatchRequestsWithResponses+ :: forall m t req a+ . ( MonadFix m+ , MonadHold t m+ , Reflex t+ , PerformEvent t m+ , MonadIO (Performable m)+ , ForallF Show req+ , Has Read req+ )+ => Event t (req a) -> m (Event t (Map Int String))+testMatchRequestsWithResponses pulse = mdo+ (_, requests) <- runRequesterT (requesting pulse) responses+ let rawResponses = M.map (\v ->+ case words v of+ ["reverse", str] -> reverse str+ ["increment", i] -> show $ succ $ (read i :: Int)+ ) <$> rawRequestMap+ (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)+ pure rawResponses+ where+ reqEncoder :: forall a. req a -> (String, String -> Maybe a)+ reqEncoder r =+ ( whichever @Show @req @a $ show r+ , \x -> has @Read r $ readMaybe x+ )++deriveArgDict ''TestRequest++instance Show (TestRequest a) where+ show = \case+ TestRequest_Reverse str -> "reverse " <> str+ TestRequest_Increment i -> "increment " <> show i