git.iko.soy/patch
on develop help sign in
Replace Const2 with TellId, a newtype
1ea9b30Ryan Trinkle
src/Reflex/EventWriter.hs+42−4
compare with develop
unifiedsplit
@@ -9,6 +9,7 @@
9{-# LANGUAGE Rank2Types #-}
9{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -36,6 +37,7 @@ import Control.Monad.Ref
36import Control.Monad.State.Strict
37import Control.Monad.State.Strict
37import Data.Dependent.Map (DMap, DSum (..))
38import Data.Dependent.Map (DMap, DSum (..))
38import qualified Data.Dependent.Map as DMap
39import qualified Data.Dependent.Map as DMap
40+import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
39import Data.Foldable
41import Data.Foldable
40import Data.Functor.Compose
42import Data.Functor.Compose
41import Data.Functor.Misc
43import Data.Functor.Misc
@@ -44,15 +46,51 @@ import Data.Map (Map)
44import Data.Semigroup
46import Data.Semigroup
45import Data.Some (Some)
47import Data.Some (Some)
46import Data.Tuple
48import Data.Tuple
49+import Data.Type.Equality
50+
51+import Unsafe.Coerce
47
52
48-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
53-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
49-- and combines them monoidally to provide an 'Event' result.
54-- and combines them monoidally to provide an 'Event' result.
50class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
55class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
51 tellEvent :: Event t w -> m ()
56 tellEvent :: Event t w -> m ()
52
57
58+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
59+newtype TellId w x
60+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
61+ deriving (Show, Read, Eq, Ord, Enum)
62+
63+tellId :: Int -> TellId w w
64+tellId = TellId
65+{-# INLINE tellId #-}
66+
67+tellIdRefl :: TellId w x -> w :~: x
68+tellIdRefl _ = unsafeCoerce Refl
69+
70+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
71+withTellIdRefl tid r = case tellIdRefl tid of
72+ Refl -> r
73+
74+instance GEq (TellId w) where
75+ a `geq` b =
76+ withTellIdRefl a $
77+ withTellIdRefl b $
78+ if a == b
79+ then Just Refl
80+ else Nothing
81+
82+instance GCompare (TellId w) where
83+ a `gcompare` b =
84+ withTellIdRefl a $
85+ withTellIdRefl b $
86+ case a `compare` b of
87+ LT -> GLT
88+ EQ -> GEQ
89+ GT -> GGT
90+
53data EventWriterState t w = EventWriterState
91data EventWriterState t w = EventWriterState
54 { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
92 { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
55− , _eventWriterState_told :: ![DSum (Const2 Int w) (Event t)] -- In increasing order
93+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
56 }
94 }
57
95
58-- | A basic implementation of 'EventWriter'.
96-- | A basic implementation of 'EventWriter'.
@@ -63,10 +101,10 @@ newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWri
63runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
101runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
64runEventWriterT (EventWriterT a) = do
102runEventWriterT (EventWriterT a) = do
65 (result, requests) <- runStateT a $ EventWriterState (-1) []
103 (result, requests) <- runStateT a $ EventWriterState (-1) []
66− let combineResults :: DMap (Const2 Int w) Identity -> w
104+ let combineResults :: DMap (TellId w) Identity -> w
67 combineResults = sconcat
105 combineResults = sconcat
68 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
106 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
69− . DMap.foldlWithKey (\vs (Const2 _) (Identity v) -> v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order
107+ . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order
70 return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests)
108 return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests)
71
109
72instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
110instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
@@ -74,7 +112,7 @@ instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m
74 let myId = _eventWriterState_nextId old
112 let myId = _eventWriterState_nextId old
75 in EventWriterState
113 in EventWriterState
76 { _eventWriterState_nextId = pred myId
114 { _eventWriterState_nextId = pred myId
77− , _eventWriterState_told = (Const2 myId :=> w) : _eventWriterState_told old
115+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
78 }
116 }
79
117
80instance EventWriter t w m => EventWriter t w (ReaderT r m) where
118instance EventWriter t w m => EventWriter t w (ReaderT r m) where