481aa4a · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add MonadIORestore to allow XHR callbacks to have access to the Gui environment

commit481aa4abc420d4cde9249a1ee9fa8d442d31e247 authorRyan Trinkle <ryan.trinkle@gmail.com> dateThu 9 Apr 2015, 17:14 (12 years ago) parent4355496

4 files changed+26−8

compare with develop

unifiedsplit

.ghci+3−2 src/Reflex/Dom/Class.hs+12−1 src/Reflex/Dom/Internal.hs+6−1 src/Reflex/Dom/Xhr.hs+5−4

.ghci+3−2

@@ -1,3 +1,4 @@

11:set -isrc

2−:set -hide-package MonadCatchIO-mtl

3−:set -hide-package monads-fd

3+-- Since we're in GHCi, we can't be using GHCJS

4+:set -isrc-ghc

src/Reflex/Dom/Class.hs+12−1

@@ -28,7 +28,7 @@ keycodeEscape :: Int

2828keycodeEscape = 27

2929

3030class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m

31− , HasDocument m, HasWebView m, HasWebView (WidgetHost m)

31+ , HasDocument m, HasWebView m, HasWebView (WidgetHost m), MonadIORestore (WidgetHost m)

3232 , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)

3333 , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)

3434 , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO

@@ -62,6 +62,17 @@ instance HasWebView m => HasWebView (ReaderT r m) where

6262instance HasWebView m => HasWebView (StateT r m) where

6363 askWebView = lift askWebView

6464

65+newtype Restore m = Restore { restore :: forall a. m a -> IO a }

66+

67+class Monad m => MonadIORestore m where

68+ askRestore :: m (Restore m)

69+

70+instance MonadIORestore m => MonadIORestore (ReaderT r m) where

71+ askRestore = do

72+ r <- ask

73+ parentRestore <- lift askRestore

74+ return $ Restore $ \a -> restore parentRestore $ runReaderT a r

75+

6576class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where

6677 askPostGui :: m (h () -> IO ())

6778 askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())

src/Reflex/Dom/Internal.hs+6−1

@@ -86,6 +86,11 @@ instance HasDocument m => HasDocument (Widget t m) where

8686instance Monad m => HasWebView (Gui t h m) where

8787 askWebView = Gui $ view guiEnvWebView

8888

89+instance MonadIORestore m => MonadIORestore (Gui t h m) where

90+ askRestore = Gui $ do

91+ r <- askRestore

92+ return $ Restore $ restore r . unGui

93+

8994instance HasWebView m => HasWebView (Widget t m) where

9095 askWebView = lift askWebView

9196

@@ -127,7 +132,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m)

127132 newEventWithTrigger = lift . newEventWithTrigger

128133

129134instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO

130− , MonadIO m, MonadIO h, Functor m

135+ , MonadIO m, MonadIO h, Functor m, MonadIORestore m

131136 , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m

132137 , MonadFix m

133138 ) => MonadWidget t (Widget t (Gui t h m)) where

src/Reflex/Dom/Xhr.hs+5−4

@@ -57,9 +57,10 @@ instance Default XhrRequestConfig where

5757xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest

5858xhrRequest = XhrRequest

5959

60−newXMLHttpRequest :: (HasWebView m, MonadIO m) => XhrRequest -> (XhrResponse -> IO a) -> m XMLHttpRequest

60+newXMLHttpRequest :: (HasWebView m, MonadIO m, MonadIORestore m) => XhrRequest -> (XhrResponse -> m a) -> m XMLHttpRequest

6161newXMLHttpRequest req cb = do

6262 wv <- askWebView

63+ rst <- askRestore

6364 liftIO $ do

6465 xhr <- xmlHttpRequestNew wv

6566 let c = _xhrRequest_config req

@@ -77,7 +78,7 @@ newXMLHttpRequest req cb = do

7778 if readyState == 4

7879 then do

7980 r <- liftIO $ xmlHttpRequestGetResponseText xhr

80− _ <- liftIO $ cb $ XhrResponse $ responseTextToText r

81+ _ <- liftIO $ restore rst $ cb $ XhrResponse $ responseTextToText r

8182 return ()

8283 else return ()

8384 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

@@ -85,14 +86,14 @@ newXMLHttpRequest req cb = do

8586

8687performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)

8788performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

88− _ <- newXMLHttpRequest r cb

89+ _ <- newXMLHttpRequest r $ liftIO . cb

8990 return ()

9091

9192performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))

9293performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

9394 resps <- forM rs $ \r -> do

9495 resp <- liftIO newEmptyMVar

95− _ <- newXMLHttpRequest r $ putMVar resp

96+ _ <- newXMLHttpRequest r $ liftIO . putMVar resp

9697 return resp

9798 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

9899 return ()