WidgetT uses IORef

yesod-core/ChangeLog.md

@@ -1,3 +1,10 @@
+## 1.4.38
+
+* Internal only change, users of stable API are unaffected: `WidgetT`
+  holds its data in an `IORef` so that it is isomorphic to `ReaderT`,
+  avoiding state-loss issues..
+* Instances for `MonadUnliftIO`
+
 ## 1.4.37.2
 
 * Improve error messages for the CSRF checking functions [#1455](https://github.com/yesodweb/yesod/issues/1455)

yesod-core/Yesod/Core/Class/Handler.hs

@@ -12,12 +12,11 @@ module Yesod.Core.Class.Handler
     ) where
 
 import Yesod.Core.Types
-import Control.Monad (liftM)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
 import Control.Monad.Trans.Class (lift)
 #if __GLASGOW_HASKELL__ < 710
-import Data.Monoid (Monoid, mempty)
+import Data.Monoid (Monoid)
 #endif
 import Data.Conduit.Internal (Pipe, ConduitM)
 
@@ -48,8 +47,8 @@ instance MonadResourceBase m => MonadHandler (HandlerT site m) where
 
 instance MonadResourceBase m => MonadHandler (WidgetT site m) where
     type HandlerSite (WidgetT site m) = site
-    liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
+    liftHandlerT (HandlerT f) = WidgetT $ \_ref env -> liftIO $ f $ replaceToParent env
-{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
+{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ const f #-}
 
 #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
 #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
@@ -73,7 +72,7 @@ GO(ConduitM i o)
 class MonadHandler m => MonadWidget m where
     liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
 instance MonadResourceBase m => MonadWidget (WidgetT site m) where
-    liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
+    liftWidgetT (WidgetT f) = WidgetT $ \ref env -> liftIO $ f ref $ replaceToParent env
 
 #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
 #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -59,6 +59,7 @@ import           Yesod.Core.Widget
 import Control.Monad.Trans.Class (lift)
 import Data.CaseInsensitive (CI)
 import qualified Network.Wai.Request
+import Data.IORef
 
 -- | Define settings for a Yesod applications. All methods have intelligent
 -- defaults, and therefore no implementation is required.
@@ -550,7 +551,9 @@ widgetToPageContent :: Yesod site
 widgetToPageContent w = do
     master <- getYesod
     hd <- HandlerT return
-    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
+    ref <- lift $ newIORef mempty
+    lift $ unWidgetT w ref hd
+    GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- lift $ readIORef ref
     let title = maybe mempty unTitle mTitle
         scripts = runUniqueList scripts'
         stylesheets = runUniqueList stylesheets'

yesod-core/Yesod/Core/Types.hs

@@ -29,7 +29,7 @@ import           Control.Monad.Trans.Resource       (MonadResource (..), Interna
 import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
 import           Data.Conduit                       (Flush, Source)
-import           Data.IORef                         (IORef)
+import           Data.IORef                         (IORef, modifyIORef')
 import           Data.Map                           (Map, unionWith)
 import qualified Data.Map                           as Map
 import           Data.Monoid                        (Endo (..), Last (..))
@@ -59,6 +59,7 @@ import           Yesod.Core.Internal.Util           (getTime, putTime)
 import           Control.Monad.Trans.Class          (MonadTrans (..))
 import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
 import           Control.Monad.Reader               (MonadReader (..))
+import           Data.Monoid                        ((<>))
 import Control.DeepSeq (NFData (rnf))
 import Control.DeepSeq.Generics (genericRnf)
 import Data.Conduit.Lazy (MonadActive, monadActive)
@@ -248,7 +249,7 @@ type YesodApp = YesodRequest -> ResourceT IO YesodResponse
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
 -- better error messages.
 newtype WidgetT site m a = WidgetT
-    { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
+    { unWidgetT :: IORef (GWData (Route site)) -> HandlerData site (MonadRoute m) -> m a
     }
 
 instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
@@ -261,10 +262,12 @@ instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
 -- For example, in a yesod-scaffold site you could use:
 --
 -- @getHomeR = do defaultLayout "Widget text"@
-instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where
+instance (MonadIO m, a ~ ()) => IsString (WidgetT site m a) where -- FIXME turn it into WidgetFor?
     fromString = toWidget . toHtml . T.pack
-      where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))
+      where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
-                         mempty mempty mempty mempty mempty mempty)
+
+tellWidget :: MonadIO m => GWData (Route site) -> WidgetT site m ()
+tellWidget d = WidgetT $ \ref _ -> liftIO $ modifyIORef' ref (<> d)
 
 type RY master = Route master -> [(Text, Text)] -> Text
 
@@ -407,32 +410,30 @@ instance Monad m => Applicative (WidgetT site m) where
     pure = return
     (<*>) = ap
 instance Monad m => Monad (WidgetT site m) where
-    return a = WidgetT $ const $ return (a, mempty)
+    return a = WidgetT $ \_ _ -> return a
-    WidgetT x >>= f = WidgetT $ \r -> do
+    WidgetT x >>= f = WidgetT $ \ref r -> do
-        (a, wa) <- x r
+        a <- x ref r
-        (b, wb) <- unWidgetT (f a) r
+        unWidgetT (f a) ref r
-        return (b, wa `mappend` wb)
 instance MonadIO m => MonadIO (WidgetT site m) where
     liftIO = lift . liftIO
 instance MonadBase b m => MonadBase b (WidgetT site m) where
-    liftBase = WidgetT . const . liftBase . fmap (, mempty)
+    liftBase = WidgetT . const . const . liftBase
 instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
-    type StM (WidgetT site m) a = StM m (a, GWData (Route site))
+    type StM (WidgetT site m) a = StM m a
-    liftBaseWith f = WidgetT $ \reader' ->
+    liftBaseWith f = WidgetT $ \ref reader' ->
         liftBaseWith $ \runInBase ->
-            fmap (\x -> (x, mempty))
+            f $ runInBase . (\(WidgetT w) -> w ref reader')
-            (f $ runInBase . flip unWidgetT reader')
+    restoreM = WidgetT . const . const . restoreM
-    restoreM = WidgetT . const . restoreM
 instance Monad m => MonadReader site (WidgetT site m) where
-    ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
+    ask = WidgetT $ \_ hd -> return (rheSite $ handlerEnv hd)
-    local f (WidgetT g) = WidgetT $ \hd -> g hd
+    local f (WidgetT g) = WidgetT $ \ref hd -> g ref hd
         { handlerEnv = (handlerEnv hd)
             { rheSite = f $ rheSite $ handlerEnv hd
             }
         }
 
 instance MonadTrans (WidgetT site) where
-    lift = WidgetT . const . liftM (, mempty)
+    lift = WidgetT . const . const
 instance MonadThrow m => MonadThrow (WidgetT site m) where
     throwM = lift . throwM
 
@@ -445,13 +446,13 @@ instance MonadMask m => MonadMask (HandlerT site m) where
     HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
       where q u (HandlerT b) = HandlerT (u . b)
 instance MonadCatch m => MonadCatch (WidgetT site m) where
-  catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
+  catch (WidgetT m) c = WidgetT $ \ref r -> m ref r `catch` \e -> unWidgetT (c e) ref r
 instance MonadMask m => MonadMask (WidgetT site m) where
-  mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
+  mask a = WidgetT $ \ref e -> mask $ \u -> unWidgetT (a $ q u) ref e
-    where q u (WidgetT b) = WidgetT (u . b)
+    where q u (WidgetT b) = WidgetT (\ref e -> u $ b ref e)
   uninterruptibleMask a =
-    WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
+    WidgetT $ \ref e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) ref e
-      where q u (WidgetT b) = WidgetT (u . b)
+      where q u (WidgetT b) = WidgetT (\ref e -> u $ b ref e)
 
 -- CPP to avoid a redundant constraints warning
 #if MIN_VERSION_base(4,9,0)
@@ -459,14 +460,14 @@ instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT sit
 #else
 instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
 #endif
-    liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)
+    liftResourceT f = WidgetT $ \_ hd -> liftIO $ runInternalState f (handlerResource hd)
 
 instance MonadIO m => MonadLogger (WidgetT site m) where
-    monadLoggerLog a b c d = WidgetT $ \hd ->
+    monadLoggerLog a b c d = WidgetT $ \_ hd ->
-        liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)
+        liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
 
 instance MonadIO m => MonadLoggerIO (WidgetT site m) where
-    askLoggerIO = WidgetT $ \hd -> return (rheLog (handlerEnv hd), mempty)
+    askLoggerIO = WidgetT $ \_ hd -> return $ rheLog $ handlerEnv hd
 
 instance MonadActive m => MonadActive (WidgetT site m) where
     monadActive = lift monadActive

yesod-core/Yesod/Core/Widget.hs

@@ -60,7 +60,6 @@ import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
-import Control.Monad (liftM)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Text.Shakespeare.I18N (RenderMessage)
 import Data.Text (Text)
@@ -73,6 +72,7 @@ import Data.Text.Lazy.Builder (fromLazyText)
 import Text.Blaze.Html (toHtml, preEscapedToMarkup)
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
+import Data.IORef
 
 import Yesod.Core.Types
 import Yesod.Core.Class.Handler
@@ -268,20 +268,24 @@ ihamletToHtml ih = do
     return $ ih (toHtml . mrender) urender
 
 tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
-tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
+tell = liftWidgetT . tellWidget
 
 toUnique :: x -> UniqueList x
 toUnique = UniqueList . (:)
 
 handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
-handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f
+handlerToWidget (HandlerT f) = WidgetT $ const f
 
 widgetToParentWidget :: MonadIO m
                      => WidgetT child IO a
                      -> HandlerT child (HandlerT parent m) (WidgetT parent m a)
-widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do
+widgetToParentWidget (WidgetT f) = HandlerT $ \hdChild -> do
-    (a, gwd) <- liftIO $ f hd { handlerToParent = const () }
+    return $ WidgetT $ \ref _hdParent -> liftIO $ do
-    return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
+      tmp <- newIORef mempty
+      a <- f tmp hdChild { handlerToParent = const () }
+      gwd <- readIORef tmp
+      modifyIORef' ref (<> liftGWD (handlerToParent hdChild) gwd)
+      return a
 
 liftGWD :: (child -> parent) -> GWData child -> GWData parent
 liftGWD tp gwd = GWData

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.37.2
+version:         1.4.38
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>