src/Reflex/EventWriter/Base.hs · patch

git.iko.soy/patch

on baac813 help sign in

patch/src/Reflex/EventWriter/Base.hs

302 lines 13 kB history raw

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

2-- 'EventWriter'.

3{-# LANGUAGE CPP #-}

4{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE Rank2Types #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13#ifdef USE_REFLEX_OPTIMIZER

14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

15#endif

16module Reflex.EventWriter.Base

17 ( EventWriterT (..)

18 , runEventWriterT

19 , runWithReplaceEventWriterTWith

20 , sequenceDMapWithAdjustEventWriterTWith

21 , mapEventWriterT

22 , withEventWriterT

23 ) where

25import Reflex.Class

26import Reflex.Adjustable.Class

27import Reflex.EventWriter.Class (EventWriter, tellEvent)

28import Reflex.Host.Class

29import Reflex.PerformEvent.Class

30import Reflex.PostBuild.Class

31import Reflex.Query.Class

32import Reflex.Requester.Class

33import Reflex.TriggerEvent.Class

35import Control.Monad.Exception

36import Control.Monad.Identity

37import Control.Monad.Primitive

38import Control.Monad.Reader

39import Control.Monad.Ref

40import Control.Monad.State.Strict

41import Data.Dependent.Map (DMap, DSum (..))

42import qualified Data.Dependent.Map as DMap

43import Data.Functor.Compose

44import Data.Functor.Misc

45import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

46import Data.IntMap.Strict (IntMap)

47import qualified Data.IntMap.Strict as IntMap

48import Data.List.NonEmpty (NonEmpty (..))

49import Data.Map (Map)

50import qualified Data.Map as Map

51import Data.Semigroup

52import Data.Some (Some)

53import Data.Tuple

54import Data.Type.Equality hiding (apply)

56import Unsafe.Coerce

58{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

59newtype TellId w x

60 = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead

61 deriving (Show, Eq, Ord, Enum)

63tellId :: Int -> TellId w w

64tellId = TellId

65{-# INLINE tellId #-}

67tellIdRefl :: TellId w x -> w :~: x

68tellIdRefl _ = unsafeCoerce Refl

70withTellIdRefl :: TellId w x -> (w ~ x => r) -> r

71withTellIdRefl tid r = case tellIdRefl tid of

72 Refl -> r

74instance 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

82instance 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

91data EventWriterState t w = EventWriterState

92 { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)

93 , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order

94 }

96-- | A basic implementation of 'EventWriter'.

97newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

98 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

100-- | Run a 'EventWriterT' action.

101runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

102runEventWriterT (EventWriterT a) = do

103 (result, requests) <- runStateT a $ EventWriterState (-1) []

104 let combineResults :: DMap (TellId w) Identity -> w

105 combineResults = sconcat

106 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

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

108 return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

109

110instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

111 tellEvent w = EventWriterT $ modify $ \old ->

112 let myId = _eventWriterState_nextId old

113 in EventWriterState

114 { _eventWriterState_nextId = pred myId

115 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

116 }

117

118instance MonadTrans (EventWriterT t w) where

119 lift = EventWriterT . lift

120

121instance MonadSample t m => MonadSample t (EventWriterT t w m) where

122 sample = lift . sample

123

124instance MonadHold t m => MonadHold t (EventWriterT t w m) where

125 {-# INLINABLE hold #-}

126 hold v0 = lift . hold v0

127 {-# INLINABLE holdDyn #-}

128 holdDyn v0 = lift . holdDyn v0

129 {-# INLINABLE holdIncremental #-}

130 holdIncremental v0 = lift . holdIncremental v0

131 {-# INLINABLE buildDynamic #-}

132 buildDynamic a0 = lift . buildDynamic a0

133 {-# INLINABLE headE #-}

134 headE = lift . headE

135

136instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where

137 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

138 traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap

139 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap

140 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove

141

142instance Requester t m => Requester t (EventWriterT t w m) where

143 type Request (EventWriterT t w m) = Request m

144 type Response (EventWriterT t w m) = Response m

145 requesting = lift . requesting

146 requesting_ = lift . requesting_

147

148-- | Given a function like 'runWithReplace' for the underlying monad, implement

149-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

150-- monad doesn't have a 'Adjustable' instance or to override the default

151-- 'Adjustable' behavior.

152runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)

153 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

154 -> EventWriterT t w m a

155 -> Event t (EventWriterT t w m b)

156 -> EventWriterT t w m (a, Event t b)

157runWithReplaceEventWriterTWith f a0 a' = do

158 (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'

159 tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')

160 return (fst result0, fmapCheap fst result')

161

162-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

163sequenceIntMapWithAdjustEventWriterTWith

164 :: forall t m p w v v'

165 . ( Reflex t

166 , MonadHold t m

167 , Semigroup w

168 , Functor p

169 , Patch (p (Event t w))

170 , PatchTarget (p (Event t w)) ~ IntMap (Event t w)

171 , Patch (p w)

172 , PatchTarget (p w) ~ IntMap w

173 )

174 => ( (IntMap.Key -> v -> m (Event t w, v'))

175 -> IntMap v

176 -> Event t (p v)

177 -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

178 )

179 -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))

180 -> (Event t (p (Event t w)) -> Event t (p w))

181 -> (IntMap.Key -> v -> EventWriterT t w m v')

182 -> IntMap v

183 -> Event t (p v)

184 -> EventWriterT t w m (IntMap v', Event t (p v'))

185sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do

186 let f' :: IntMap.Key -> v -> m (Event t w, v')

187 f' k v = swap <$> runEventWriterT (f k v)

188 (children0, children') <- base f' dm0 dm'

189 let result0 = fmap snd children0

190 result' = fmapCheap (fmap snd) children'

191 requests0 :: IntMap (Event t w)

192 requests0 = fmap fst children0

193 requests' :: Event t (p (Event t w))

194 requests' = fmapCheap (fmap fst) children'

195 e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

196 tellEvent $ fforMaybeCheap e $ \m ->

197 case IntMap.elems m of

198 [] -> Nothing

199 h : t -> Just $ sconcat $ h :| t

200 return (result0, result')

201

202-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

203sequenceDMapWithAdjustEventWriterTWith

204 :: forall t m p p' w k v v'

205 . ( Reflex t

206 , MonadHold t m

207 , Semigroup w

208 , Patch (p' (Some k) (Event t w))

209 , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)

210 , GCompare k

211 , Patch (p' (Some k) w)

212 , PatchTarget (p' (Some k) w) ~ Map (Some k) w

213 )

214 => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

215 -> DMap k v

216 -> Event t (p k v)

217 -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

218 )

219 -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

220 -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

221 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))

222 -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))

223 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

224 -> DMap k v

225 -> Event t (p k v)

226 -> EventWriterT t w m (DMap k v', Event t (p k v'))

227sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do

228 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)

229 f' k v = Compose . swap <$> runEventWriterT (f k v)

230 (children0, children') <- base f' dm0 dm'

231 let result0 = DMap.map (snd . getCompose) children0

232 result' = fforCheap children' $ mapPatch $ snd . getCompose

233 requests0 :: Map (Some k) (Event t w)

234 requests0 = weakenDMapWith (fst . getCompose) children0

235 requests' :: Event t (p' (Some k) (Event t w))

236 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

237 e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

238 tellEvent $ fforMaybeCheap e $ \m ->

239 case Map.elems m of

240 [] -> Nothing

241 h : t -> Just $ sconcat $ h :| t

242 return (result0, result')

243

244instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

245 type Performable (EventWriterT t w m) = Performable m

246 performEvent_ = lift . performEvent_

247 performEvent = lift . performEvent

248

249instance PostBuild t m => PostBuild t (EventWriterT t w m) where

250 getPostBuild = lift getPostBuild

251

252instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where

253 newTriggerEvent = lift newTriggerEvent

254 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

255 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

256

257instance MonadReader r m => MonadReader r (EventWriterT t w m) where

258 ask = lift ask

259 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a

260 reader = lift . reader

261

262instance MonadRef m => MonadRef (EventWriterT t w m) where

263 type Ref (EventWriterT t w m) = Ref m

264 newRef = lift . newRef

265 readRef = lift . readRef

266 writeRef r = lift . writeRef r

267

268instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

269 atomicModifyRef r = lift . atomicModifyRef r

270

271instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

272 newEventWithTrigger = lift . newEventWithTrigger

273 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

274

275instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where

276 tellQueryIncremental = lift . tellQueryIncremental

277 askQueryResult = lift askQueryResult

278 queryIncremental = lift . queryIncremental

279

280instance PrimMonad m => PrimMonad (EventWriterT t w m) where

281 type PrimState (EventWriterT t w m) = PrimState m

282 primitive = lift . primitive

283

284-- | Map a function over the output of a 'EventWriterT'.

285withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)

286 => (w -> w')

287 -> EventWriterT t w m a

288 -> EventWriterT t w' m a

289withEventWriterT f ew = do

290 (r, e) <- lift $ do

291 (r, e) <- runEventWriterT ew

292 let e' = fmap f e

293 return (r, e')

294 tellEvent e

295 return r

296

297-- | Change the monad underlying an EventWriterT

298mapEventWriterT

299 :: (forall x. m x -> n x)

300 -> EventWriterT t w m a

301 -> EventWriterT t w n a

302mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a