f0eb57a · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Add some instances and new functions

f0eb57aRyan Trinkle10 years ago

src/Reflex/DynamicWriter.hs+17

compare with develop

unifiedsplit

@@ -177,3 +177,20 @@ instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Mon

177 i <- holdIncremental liftedWritten0 liftedWritten'

178 tellDyn $ join $ fold . dmapToMap <$> incrementalToDynamic i

179 return (liftedResult0, liftedResult')

180+

181+withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)

182+ => (w -> w')

183+ -> DynamicWriterT t w m a

184+ -> DynamicWriterT t w' m a

185+withDynamicWriterT f dw = do

186+ (r, d) <- lift $ do

187+ (r, d) <- runDynamicWriterT dw

188+ let d' = fmap f d

189+ return (r, d')

190+ tellDyn d

191+ return r

192+

193+instance MonadRequest t m => MonadRequest t (DynamicWriterT t w m) where

194+ type Request (DynamicWriterT t w m) = Request m

195+ type Response (DynamicWriterT t w m) = Response m

196+ withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

src/Reflex/PerformEvent/Base.hs+56−15

@@ -16,6 +16,7 @@ module Reflex.PerformEvent.Base where

17import Reflex.Class

18import Reflex.Host.Class

19+import Reflex.PostBuild.Class

19import Reflex.PerformEvent.Class

20import Reflex.PerformEvent.Class

21import Control.Lens

22import Control.Lens

@@ -52,6 +53,10 @@ deriving instance ReflexHost t => MonadFix (PerformEventT t m)

52deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

53deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

53deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

54deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

56+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where

57+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)

58+ primitive = PerformEventT . lift . primitive

59+

55instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where

60instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where

56 type Performable (PerformEventT t m) = HostFrame t

61 type Performable (PerformEventT t m) = HostFrame t

57 {-# INLINABLE performEvent_ #-}

62 {-# INLINABLE performEvent_ #-}

@@ -153,21 +158,15 @@ runRequestT (RequestT a) responses = do

153 (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

158 (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

154 return (result, mergeWith DMap.union requests)

159 return (result, mergeWith DMap.union requests)

155

160

156−requesting_ :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m ()

161+instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response m) where

157−requesting_ req = do

162+ type Request (RequestT t request response m) = request

158− t <- lift newTag

159− RequestT $ modify $ (:) $ DMap.singleton t <$> req

160−

161−withRequesting :: (Reflex t, PrimMonad m) => (Event t (response a) -> RequestT t request response m (Event t (request a), r)) -> RequestT t request response m r

163+ type Response (RequestT t request response m) = response

162−withRequesting a = do

164+ withRequesting a = do

163− t <- lift newTag

165+ t <- lift newTag

164− s <- RequestT ask

166+ s <- RequestT ask

165− (req, result) <- a $ select s $ WrapArg t

167+ (req, result) <- a $ select s $ WrapArg t

166− RequestT $ modify $ (:) $ DMap.singleton t <$> req

168+ RequestT $ modify $ (:) $ DMap.singleton t <$> req

167− return result

169+ return result

168−

169−requesting :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m (Event t (response a))

170−requesting req = withRequesting $ return . (,) req

171

170

172data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

171data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

173

172

@@ -217,6 +216,48 @@ sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response

217-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> Compose me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)

216-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> Compose me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)

218 return (result0, result')

217 return (result0, result')

219

218

219+instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

220+ type Performable (RequestT t request response m) = Performable m

221+ performEvent_ = lift . performEvent_

222+ performEvent = lift . performEvent

223+

224+instance PostBuild t m => PostBuild t (RequestT t request response m) where

225+ getPostBuild = lift getPostBuild

226+

227+instance TriggerEvent t m => TriggerEvent t (RequestT t request response m) where

228+ newTriggerEvent = lift newTriggerEvent

229+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

230+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

231+

232+instance MonadReader r m => MonadReader r (RequestT t request response m) where

233+ ask = lift ask

234+ local f (RequestT a) = RequestT $ mapStateT (mapReaderT $ local f) a

235+ reader = lift . reader

236+

237+{-

238+withRequestT :: forall t m a (req :: * -> *) (req' :: * -> *).

239+ (Reflex t, MonadHold t m, MonadFix m)

240+ => (forall x. request x -> request' x)

241+ -> (forall x. response' x -> response x)

242+ -> RequestT t request response m a

243+ -> RequestT t request' response m a

244+withRequestT f g m = RequestT $ hoist (hoist (withDynamicWriterT f')) (unRequestT m)

245+ where

246+ f' :: Event t [(y, Some request)] -> Event t [(y, Some request')]

247+ f' = fmap . fmap . fmap $ \(SomeRequest req) -> SomeRequest $ f req

248+-}

249+

250+instance MonadRef m => MonadRef (RequestT t request response m) where

251+ type Ref (RequestT t request response m) = Ref m

252+ newRef = lift . newRef

253+ readRef = lift . readRef

254+ writeRef r = lift . writeRef r

255+

256+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequestT t request response m) where

257+ newEventWithTrigger = lift . newEventWithTrigger

258+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

259+

260+

220--------------------------------------------------------------------------------

261--------------------------------------------------------------------------------

221-- Helpers

262-- Helpers

222--------------------------------------------------------------------------------

263--------------------------------------------------------------------------------

src/Reflex/PerformEvent/Class.hs+46

@@ -11,7 +11,10 @@ module Reflex.PerformEvent.Class where

12import Reflex.Class

14+import Control.Monad.Identity

14import Control.Monad.Reader

15import Control.Monad.Reader

16+import qualified Control.Monad.State.Lazy as Lazy

17+import Control.Monad.State.Strict

16class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where

19class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where

17 type Performable m :: * -> *

20 type Performable m :: * -> *

@@ -24,6 +27,11 @@ class Monad m => TriggerEvent t m | m -> t where

24 newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow

27 newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow

25 newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)

28 newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)

30+class (Reflex t, Monad m) => MonadRequest t m | m -> t where

31+ type Request m :: * -> *

32+ type Response m :: * -> *

33+ withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

34+

27{-# INLINABLE performEventAsync #-}

35{-# INLINABLE performEventAsync #-}

28performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)

36performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)

29performEventAsync e = do

37performEventAsync e = do

@@ -44,3 +52,41 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

44 newTriggerEvent = lift newTriggerEvent

52 newTriggerEvent = lift newTriggerEvent

45 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

53 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

46 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

54 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

55+

56+instance MonadRequest t m => MonadRequest t (ReaderT r m) where

57+ type Request (ReaderT r m) = Request m

58+ type Response (ReaderT r m) = Response m

59+ withRequesting f = do

60+ r <- ask

61+ lift $ withRequesting $ (`runReaderT` r) . f

62+

63+instance MonadRequest t m => MonadRequest t (StateT s m) where

64+ type Request (StateT s m) = Request m

65+ type Response (StateT s m) = Response m

66+ withRequesting f = do

67+ old <- get

68+ (result, new) <- lift $ withRequesting $ \x -> do

69+ ((request, result), new) <- runStateT (f x) old

70+ return (request, (result, new))

71+ put new

72+ return result

73+

74+instance MonadRequest t m => MonadRequest t (Lazy.StateT s m) where

75+ type Request (Lazy.StateT s m) = Request m

76+ type Response (Lazy.StateT s m) = Response m

77+ withRequesting f = do

78+ old <- Lazy.get

79+ (result, new) <- lift $ withRequesting $ \x -> do

80+ ((request, result), new) <- Lazy.runStateT (f x) old

81+ return (request, (result, new))

82+ Lazy.put new

83+ return result

84+

85+requesting :: MonadRequest t m => Event t (Request m a) -> m (Event t (Response m a))

86+requesting req = withRequesting $ return . (,) req

87+

88+requesting_ :: MonadRequest t m => Event t (Request m a) -> m ()

89+requesting_ req = withRequesting $ \_ -> return (req, ())

90+

91+requestingIdentity :: (MonadRequest t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

92+requestingIdentity = fmap (fmap runIdentity) . requesting

src/Reflex/PostBuild/Class.hs+5

@@ -11,6 +11,7 @@

11module Reflex.PostBuild.Class where

13import Control.Monad.Exception

14+import Control.Monad.Primitive

14import Control.Monad.Reader

15import Control.Monad.Reader

15import Control.Monad.Ref

16import Control.Monad.Ref

16import Control.Monad.Trans.Control

17import Control.Monad.Trans.Control

@@ -25,6 +26,10 @@ class (Reflex t, Monad m) => PostBuild t m | m -> t where

26newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

27newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

29+instance PrimMonad m => PrimMonad (PostBuildT x m) where

30+ type PrimState (PostBuildT x m) = PrimState m

31+ primitive = lift . primitive

32+

28instance MonadTransControl (PostBuildT t) where

33instance MonadTransControl (PostBuildT t) where

29 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

34 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

30 {-# INLINABLE liftWith #-}

35 {-# INLINABLE liftWith #-}