@@ -9,6 +9,7 @@
99{-# LANGUAGE Rank2Types #-}
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
1213{-# LANGUAGE UndecidableInstances #-}
1314#ifdef USE_REFLEX_OPTIMIZER
1415{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -36,6 +37,7 @@ import Control.Monad.Ref
3637import Control.Monad.State.Strict
3738import Data.Dependent.Map (DMap, DSum (..))
3839import qualified Data.Dependent.Map as DMap
40+import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
3941import Data.Foldable
4042import Data.Functor.Compose
4143import Data.Functor.Misc
@@ -44,15 +46,51 @@ import Data.Map (Map)
4446import Data.Semigroup
4547import Data.Some (Some)
4648import Data.Tuple
49+import Data.Type.Equality
50+
51+import Unsafe.Coerce
4752
4853-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
4954-- and combines them monoidally to provide an 'Event' result.
5055class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
5156 tellEvent :: Event t w -> m ()
5257
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+
5391data EventWriterState t w = EventWriterState
5492 { _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
5694 }
5795
5896-- | A basic implementation of 'EventWriter'.
@@ -63,10 +101,10 @@ newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWri
63101runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
64102runEventWriterT (EventWriterT a) = do
65103 (result, requests) <- runStateT a $ EventWriterState (-1) []
66− let combineResults :: DMap (Const2 Int w) Identity -> w
104+ let combineResults :: DMap (TellId w) Identity -> w
67105 combineResults = sconcat
68106 . (\(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
70108 return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests)
71109
72110instance (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
74112 let myId = _eventWriterState_nextId old
75113 in EventWriterState
76114 { _eventWriterState_nextId = pred myId
77− , _eventWriterState_told = (Const2 myId :=> w) : _eventWriterState_told old
115+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
78116 }
79117
80118instance EventWriter t w m => EventWriter t w (ReaderT r m) where