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

.ghci

@@ -1,3 +1,4 @@
 :set -isrc
-:set -hide-package MonadCatchIO-mtl
-:set -hide-package monads-fd
+
+-- Since we're in GHCi, we can't be using GHCJS
+:set -isrc-ghc

src/Reflex/Dom/Class.hs

@@ -28,7 +28,7 @@ keycodeEscape :: Int
 keycodeEscape = 27
 
 class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m
-      , HasDocument m, HasWebView m, HasWebView (WidgetHost m)
+      , HasDocument m, HasWebView m, HasWebView (WidgetHost m), MonadIORestore (WidgetHost m)
       , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m)
       , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, MonadRef m, MonadRef (WidgetHost m)
       , 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
 instance HasWebView m => HasWebView (StateT r m) where
   askWebView = lift askWebView
 
+newtype Restore m = Restore { restore :: forall a. m a -> IO a }
+
+class Monad m => MonadIORestore m where
+  askRestore :: m (Restore m)
+
+instance MonadIORestore m => MonadIORestore (ReaderT r m) where
+  askRestore = do
+    r <- ask
+    parentRestore <- lift askRestore
+    return $ Restore $ \a -> restore parentRestore $ runReaderT a r
+
 class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
   askPostGui :: m (h () -> IO ())
   askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())

src/Reflex/Dom/Internal.hs

@@ -86,6 +86,11 @@ instance HasDocument m => HasDocument (Widget t m) where
 instance Monad m => HasWebView (Gui t h m) where
   askWebView = Gui $ view guiEnvWebView
 
+instance MonadIORestore m => MonadIORestore (Gui t h m) where
+  askRestore = Gui $ do
+    r <- askRestore
+    return $ Restore $ restore r . unGui
+
 instance HasWebView m => HasWebView (Widget t m) where
   askWebView = lift askWebView
 
@@ -127,7 +132,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m)
   newEventWithTrigger = lift . newEventWithTrigger
 
 instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO
-         , MonadIO m, MonadIO h, Functor m
+         , MonadIO m, MonadIO h, Functor m, MonadIORestore m
          , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m
          , MonadFix m
          ) => MonadWidget t (Widget t (Gui t h m)) where

src/Reflex/Dom/Xhr.hs

@@ -57,9 +57,10 @@ instance Default XhrRequestConfig where
 xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
 xhrRequest = XhrRequest
 
-newXMLHttpRequest :: (HasWebView m, MonadIO m) => XhrRequest -> (XhrResponse -> IO a) -> m XMLHttpRequest
+newXMLHttpRequest :: (HasWebView m, MonadIO m, MonadIORestore m) => XhrRequest -> (XhrResponse -> m a) -> m XMLHttpRequest
 newXMLHttpRequest req cb = do
   wv <- askWebView
+  rst <- askRestore
   liftIO $ do
     xhr <- xmlHttpRequestNew wv
     let c = _xhrRequest_config req
@@ -77,7 +78,7 @@ newXMLHttpRequest req cb = do
       if readyState == 4
           then do
             r <- liftIO $ xmlHttpRequestGetResponseText xhr
-            _ <- liftIO $ cb $ XhrResponse $ responseTextToText r
+            _ <- liftIO $ restore rst $ cb $ XhrResponse $ responseTextToText r
             return ()
           else return ()
     _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
@@ -85,14 +86,14 @@ newXMLHttpRequest req cb = do
 
 performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
 performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
-  _ <- newXMLHttpRequest r cb
+  _ <- newXMLHttpRequest r $ liftIO . cb
   return ()
 
 performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
 performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
   resps <- forM rs $ \r -> do
     resp <- liftIO newEmptyMVar
-    _ <- newXMLHttpRequest r $ putMVar resp
+    _ <- newXMLHttpRequest r $ liftIO . putMVar resp
     return resp
   _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
   return ()