develop...123b62e · reflex

git.iko.soy/reflex

7 files changed+215−63

since splitsnapshots

unifiedsplit

ChangeLog.md+2−9 default.nix−1 reflex.cabal+2 src/Reflex/Patch/DMapWithReset.hs+120 src/Reflex/Patch/Patchable.hs+44 src/Reflex/Pure.hs+1−2 src/Reflex/Spider/Internal.hs+46−51

ChangeLog.md+2−9

@@ -17,21 +17,14 @@

1717## 0.6.2.1

1818

1919* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`

20− functor:

21− * `fan` to `fanG`

22− * `EventSelectorG` for `fanG` result selector.

23−

24−* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.

25− * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)

26− * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic

20+ values.

2721

2822* Generalize merging functions:

2923 `merge` to `mergeG`,

3024 `mergeIncremental` to `mergeIncrementalG`,

25+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

3126 `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

3227

33−* Generalize distribute function:

34− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

3528

3629## 0.6.2.0

3730

default.nix−1

@@ -23,7 +23,6 @@ mkDerivation {

2323 base bifunctors containers deepseq dependent-map dependent-sum

2424 mtl ref-tf split transformers data-default

2525 random time unbounded-delays monoidal-containers witherable

26− profunctors

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

2827 ghcjs-base

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

reflex.cabal+2

@@ -115,9 +115,11 @@ library

115115 Reflex.Patch.Class,

116116 Reflex.Patch.DMap,

117117 Reflex.Patch.DMapWithMove,

118+ Reflex.Patch.DMapWithReset,

118119 Reflex.Patch.IntMap,

119120 Reflex.Patch.Map,

120121 Reflex.Patch.MapWithMove,

122+ Reflex.Patch.Patchable,

121123 Reflex.PerformEvent.Base,

122124 Reflex.PerformEvent.Class,

123125 Reflex.PostBuild.Base,

src/Reflex/Patch/DMapWithReset.hsnew file+120

@@ -0,0 +1,120 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE Rank2Types #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

13+{-# OPTIONS_GHC -Wall #-}

14+

15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

16+module Reflex.Patch.DMapWithReset where

17+

18+import Reflex.Patch.Class

19+

20+import Data.Dependent.Map (DMap, GCompare (..))

21+import qualified Data.Dependent.Map as DMap

22+import Data.Semigroup (Semigroup (..))

23+import Data.Constraint.Extras

24+

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

26+-- Insertions are represented as @'ComposeMaybe' (Just value)@,

27+-- while deletions are represented as @'ComposeMaybe' Nothing@.

28+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }

29+

30+-- | Holds the information about each key: where its new value should come from,

31+-- and where its old value should go to

32+data By p a

33+ = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here

34+ | By_Delete -- ^ Delete the existing value, if any, from here

35+ | By_Patch (p a) -- ^ Patch the value here with the given patch

36+

37+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where

38+ x@(By_Insert _) <> _ = x

39+ By_Delete <> _ = By_Delete

40+ By_Patch x <> By_Insert y = By_Insert (applyAlways x y)

41+ By_Patch x <> By_Patch y = By_Patch (x <> y)

42+ By_Patch _ <> By_Delete = By_Delete

43+

44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where

45+ mappend = (<>)

46+ mempty = By_Patch mempty

47+

48+instance

49+ ( GCompare k

50+ , Has' Semigroup k p

51+ , Has' Patch k p

52+ )

53+ => Semigroup (PatchDMapWithReset k p) where

54+ PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey

55+ (\k -> has' @Patch @p k

56+ $ has' @Semigroup @p k

57+ $ (<>)) xs ys

58+

59+instance

60+ ( GCompare k

61+ , Has' Semigroup k p

62+ , Has' Patch k p

63+ )

64+ => Monoid (PatchDMapWithReset k p) where

65+ mappend = (<>)

66+ mempty = PatchDMapWithReset DMap.empty

67+

68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where

69+ type Patches1LocallyTarget p :: k -> *

70+

71+data These1 f g x

72+ = This1 (f x)

73+ | That1 (g x)

74+ | These1 (f x) (g x)

75+

76+mergeWithKey

77+ :: forall k v1 v2 v.

78+ (GCompare k)

79+ => (forall x. k x -> v1 x -> Maybe (v x))

80+ -> (forall x. k x -> v2 x -> Maybe (v x))

81+ -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))

82+ -> DMap k v1 -> DMap k v2 -> DMap k v

83+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)

84+ where

85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys

86+ doIt _ _ _ = error "mergeWithKey misalligned keys"

87+

88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)

89+ onlyThat k = \case

90+ This1 xs -> f k xs

91+ That1 ys -> g k ys

92+ These1 xs ys -> fg k xs ys

93+{-# INLINE mergeWithKey #-}

94+

95+-- | Apply the insertions or deletions to a given 'DMap'.

96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where

97+

98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)

99+

100+ apply = go

101+ where

102+ go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))

103+ go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff

104+ where

105+ updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)

106+ updates k ys = has @(Patches1Locally p) k $ \case

107+ By_Insert x -> Just x

108+ By_Delete -> Nothing

109+ By_Patch x -> Just $ applyAlways x ys

110+

111+ inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)

112+ inserts k = has @(Patches1Locally p) k $ \case

113+ By_Insert x -> Just x

114+ By_Delete -> Nothing

115+ By_Patch _ -> Nothing

116+

117+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)

118+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)

119+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)

120+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)

src/Reflex/Patch/Patchable.hsnew file+44

@@ -0,0 +1,44 @@

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeFamilies #-}

7+-- The derived instances are undecidable in the case of a pathological instance like

8+-- instance Patch x where

9+-- type PatchTarget x = Patchable x

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+module Reflex.Patch.Patchable where

13+

14+-- import Data.Aeson

15+import GHC.Generics

16+import Reflex.Patch

17+

18+-- | Like SemiMap/PartialMap but for anything patchable

19+data Patchable p

20+ = Patchable_Patch p

21+ | Patchable_Complete (PatchTarget p)

22+ deriving (Generic)

23+

24+completePatchable :: Patchable p -> Maybe (PatchTarget p)

25+completePatchable = \case

26+ Patchable_Complete t -> Just t

27+ Patchable_Patch _ -> Nothing

28+

29+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)

30+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)

31+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)

32+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)

33+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)

34+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)

35+

36+instance (Monoid p, Patch p) => Monoid (Patchable p) where

37+ mempty = Patchable_Patch mempty

38+ mappend = (<>)

39+

40+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where

41+ (<>) = curry $ \case

42+ (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b

43+ (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b

44+ (Patchable_Complete a, _) -> Patchable_Complete a

src/Reflex/Pure.hs+1−2

@@ -88,8 +88,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

8888 then Nothing

8989 else Just currentOccurrences

9090

91−-- The instance signature doeesn't compile, leave commented for documentation

92−-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v

91+ -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v

9392 fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k

9493

9594 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a

src/Reflex/Spider/Internal.hs+46−51

@@ -211,6 +211,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1

211211

212212newNodeId :: IO Int

213213newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

214+

215+{-# NOINLINE unsafeNodeId #-}

216+unsafeNodeId :: a -> Int

217+unsafeNodeId a = unsafePerformIO $ do

218+ touch a

219+ newNodeId

214220#endif

215221

216222--------------------------------------------------------------------------------

@@ -314,10 +320,9 @@ cacheEvent e =

314320#else

315321 Event $

316322#endif

317− unsafePerformIO $ do

318− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

319− <- newIORef emptyFastWeak

320− pure $ \sub -> {-# SCC "cacheEvent" #-} do

323+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

324+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak

325+ in \sub -> {-# SCC "cacheEvent" #-} do

321326#ifdef DEBUG_TRACE_EVENTS

322327 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

323328#endif

@@ -1206,12 +1211,18 @@ buildDynamic readV0 v' = do

12061211 return d

12071212

12081213unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1209−unsafeBuildDynamic readV0 v' =

1210− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')

1214+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x

1215+ where x = (readV0, v')

12111216

12121217-- ResultM can read behaviors and events

12131218type ResultM = EventM

12141219

1220+{-# NOINLINE unsafeNewIORef #-}

1221+unsafeNewIORef :: a -> b -> IORef b

1222+unsafeNewIORef a b = unsafePerformIO $ do

1223+ touch a

1224+ newIORef b

1225+

12151226instance HasSpiderTimeline x => Functor (Event x) where

12161227 fmap f = push $ return . Just . f

12171228

@@ -1224,35 +1235,26 @@ push f e = cacheEvent (pushCheap f e)

12241235

12251236{-# INLINABLE pull #-}

12261237pull :: BehaviorM x a -> Behavior x a

1227−pull a = unsafePerformIO $ do

1228− ref <- newIORef Nothing

1238+pull a = behaviorPull $ Pull

1239+ { pullCompute = a

1240+ , pullValue = unsafeNewIORef a Nothing

12291241#ifdef DEBUG_NODEIDS

1230− nid <- newNodeId

1242+ , pullNodeId = unsafeNodeId a

12311243#endif

1232− pure $ behaviorPull $ Pull

1233− { pullCompute = a

1234− , pullValue = ref

1235−#ifdef DEBUG_NODEIDS

1236− , pullNodeId = nid

1237−#endif

1238− }

1244+ }

12391245

12401246{-# INLINABLE switch #-}

12411247switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1242−switch a = unsafePerformIO $ do

1243− ref <- newIORef Nothing

1244− pure $ eventSwitch $ Switch

1245− { switchParent = a

1246− , switchSubscribed = ref

1247− }

1248+switch a = eventSwitch $ Switch

1249+ { switchParent = a

1250+ , switchSubscribed = unsafeNewIORef a Nothing

1251+ }

12481252

12491253coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1250−coincidence a = unsafePerformIO $ do

1251− ref <- newIORef Nothing

1252− pure $ eventCoincidence $ Coincidence

1253− { coincidenceParent = a

1254− , coincidenceSubscribed = ref

1255− }

1254+coincidence a = eventCoincidence $ Coincidence

1255+ { coincidenceParent = a

1256+ , coincidenceSubscribed = unsafeNewIORef a Nothing

1257+ }

12561258

12571259-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

12581260run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

@@ -1456,9 +1458,6 @@ getRootSubscribed k r sub = do

14561458 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

14571459 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

14581460 writeIORef uninitRef $! uninit

1459−#ifdef DEBUG_NODEIDS

1460− nid <- newNodeId

1461−#endif

14621461 let !subscribed = RootSubscribed

14631462 { rootSubscribedKey = k

14641463 , rootSubscribedCachedSubscribed = cached

@@ -1467,7 +1466,7 @@ getRootSubscribed k r sub = do

14671466 , rootSubscribedUninit = uninit

14681467 , rootSubscribedWeakSelf = weakSelf

14691468#ifdef DEBUG_NODEIDS

1470− , rootSubscribedNodeId = nid

1469+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

14711470#endif

14721471 }

14731472 -- If we die at the same moment that all our children die, they will

@@ -1516,10 +1515,16 @@ newFanInt = do

15161515 , _fanInt_occRef = occRef

15171516 }

15181517

1518+{-# NOINLINE unsafeNewFanInt #-}

1519+unsafeNewFanInt :: b -> FanInt x a

1520+unsafeNewFanInt b = unsafePerformIO $ do

1521+ touch b

1522+ newFanInt

1523+

15191524fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1520−fanInt p = unsafePerformIO $ do

1521− self <- newFanInt

1522− pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1525+fanInt p =

1526+ let self = unsafeNewFanInt p

1527+ in EventSelectorInt $ \k -> Event $ \sub -> do

15231528 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

15241529 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

15251530 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

@@ -1573,16 +1578,13 @@ getFanSubscribed k f sub = do

15731578 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

15741579 occRef <- liftIO $ newIORef parentOcc

15751580 when (isJust parentOcc) $ scheduleClear occRef

1576−#ifdef DEBUG_NODEIDS

1577− nid <- liftIO newNodeId

1578−#endif

15791581 let subscribed = FanSubscribed

15801582 { fanSubscribedCachedSubscribed = fanSubscribed f

15811583 , fanSubscribedOccurrence = occRef

15821584 , fanSubscribedParent = subscription

15831585 , fanSubscribedSubscribers = subscribersRef

15841586#ifdef DEBUG_NODEIDS

1585− , fanSubscribedNodeId = nid

1587+ , fanSubscribedNodeId = unsafeNodeId f

15861588#endif

15871589 }

15881590 let !self = (k, subscribed)

@@ -1642,9 +1644,6 @@ getSwitchSubscribed s sub = do

16421644 when (isJust parentOcc) $ scheduleClear occRef

16431645 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

16441646 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1645−#ifdef DEBUG_NODEIDS

1646− nid <- liftIO newNodeId

1647−#endif

16481647 let !subscribed = SwitchSubscribed

16491648 { switchSubscribedCachedSubscribed = switchSubscribed s

16501649 , switchSubscribedOccurrence = occRef

@@ -1657,7 +1656,7 @@ getSwitchSubscribed s sub = do

16571656 , switchSubscribedCurrentParent = subscriptionRef

16581657 , switchSubscribedWeakSelf = weakSelf

16591658#ifdef DEBUG_NODEIDS

1660− , switchSubscribedNodeId = nid

1659+ , switchSubscribedNodeId = unsafeNodeId s

16611660#endif

16621661 }

16631662 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

@@ -1702,9 +1701,6 @@ getCoincidenceSubscribed c sub = do

17021701 scheduleClear innerSubdRef

17031702 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

17041703 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1705−#ifdef DEBUG_NODEIDS

1706− nid <- liftIO newNodeId

1707−#endif

17081704 let subscribed = CoincidenceSubscribed

17091705 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

17101706 , coincidenceSubscribedOccurrence = occRef

@@ -1715,7 +1711,7 @@ getCoincidenceSubscribed c sub = do

17151711 , coincidenceSubscribedInnerParent = innerSubdRef

17161712 , coincidenceSubscribedWeakSelf = weakSelf

17171713#ifdef DEBUG_NODEIDS

1718− , coincidenceSubscribedNodeId = nid

1714+ , coincidenceSubscribedNodeId = unsafeNodeId c

17191715#endif

17201716 }

17211717 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

@@ -2089,13 +2085,12 @@ newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a

20892085newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

20902086

20912087fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v

2092−fanG e = unsafePerformIO $ do

2093− ref <- newIORef Nothing

2088+fanG e =

20942089 let f = Fan

20952090 { fanParent = e

2096− , fanSubscribed = ref

2091+ , fanSubscribed = unsafeNewIORef e Nothing

20972092 }

2098− pure $ EventSelectorG $ \k -> eventFan k f

2093+ in EventSelectorG $ \k -> eventFan k f

20992094

21002095runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()

21012096runHoldInits holdInitRef dynInitRef mergeInitRef = do