Merge pull request #1764 from parsonsmatt/matt/yesod-test-expose-sio

Expose SIO type

yesod-test/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-test
 
+## 1.6.13
+
+* Add `Yesod.Test.Internal.SIO` module to expose the `SIO` type.
+
 ## 1.6.12
 
 * Fix import in cookie example [#1713](https://github.com/yesodweb/yesod/pull/1713)

yesod-test/Yesod/Test.hs

@@ -243,10 +243,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Network.Wai
 import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
-import Control.Monad.Trans.Reader (ReaderT (..))
-import Conduit (MonadThrow)
 import Control.Monad.IO.Class
-import qualified Control.Monad.State.Class as MS
 import System.IO
 import Yesod.Core.Unsafe (runFakeHandler)
 import Yesod.Test.TransversingCSS
@@ -257,7 +254,6 @@ import Text.XML.Cursor hiding (element)
 import qualified Text.XML.Cursor as C
 import qualified Text.HTML.DOM as HD
 import Control.Monad.Trans.Writer
-import Data.IORef
 import qualified Data.Map as M
 import qualified Web.Cookie as Cookie
 import qualified Blaze.ByteString.Builder as Builder
@@ -281,6 +277,7 @@ import Data.Aeson (FromJSON, eitherDecode')
 import Control.Monad (unless)
 
 import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
+import Yesod.Test.Internal.SIO
 
 {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-}
 {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-}
@@ -431,7 +428,7 @@ yit :: String -> YesodExample site () -> YesodSpec site
 yit label example = tell [YesodSpecItem label example]
 
 -- | Modifies the site ('yedSite') of the test, and creates a new WAI app ('yedApp') for it.
--- 
+--
 -- yesod-test allows sending requests to your application to test that it handles them correctly.
 -- In rare cases, you may wish to modify that application in the middle of a test.
 -- This may be useful if you wish to, for example, test your application under a certain configuration,
@@ -455,7 +452,7 @@ testModifySite :: YesodDispatch site
                => (site -> IO (site, Middleware)) -- ^ A function from the existing site, to a new site and middleware for a WAI app.
                -> YesodExample site ()
 testModifySite newSiteFn = do
-  currentSite <- getTestYesod 
+  currentSite <- getTestYesod
   (newSite, middleware) <- liftIO $ newSiteFn currentSite
   app <- liftIO $ toWaiAppPlain newSite
   modifySIO $ \yed -> yed { yedSite = newSite, yedApp = middleware app }
@@ -812,7 +809,7 @@ printMatches query = do
   matches <- htmlQuery query
   liftIO $ hPutStrLn stderr $ show matches
 
--- | Add a parameter with the given name and value to the request body. 
+-- | Add a parameter with the given name and value to the request body.
 -- This function can be called multiple times to add multiple parameters, and be mixed with calls to 'addFile'.
 --
 -- "Post parameter" is an informal description of what is submitted by making an HTTP POST with an HTML @\<form\>@.
@@ -1367,7 +1364,7 @@ setUrl url' = do
 -- > get "/foobar"
 -- > clickOn "a#idofthelink"
 --
--- @since 1.5.7 
+-- @since 1.5.7
 clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
 clickOn query = do
   withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
@@ -1596,32 +1593,3 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe
                 return ())
             params
             ($ ())
-
--- | State + IO
---
--- @since 1.6.0
-newtype SIO s a = SIO (ReaderT (IORef s) IO a)
-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
-
-instance MS.MonadState s (SIO s)
-  where
-  get = getSIO
-  put = putSIO
-
-getSIO :: SIO s s
-getSIO = SIO $ ReaderT readIORef
-
-putSIO :: s -> SIO s ()
-putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
-
-modifySIO :: (s -> s) -> SIO s ()
-modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
-
-evalSIO :: SIO s a -> s -> IO a
-evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
-
-execSIO :: SIO s () -> s -> IO s
-execSIO (SIO (ReaderT f)) s = do
-  ref <- newIORef s
-  f ref
-  readIORef ref

yesod-test/Yesod/Test/Internal/SIO.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | The 'SIO' type is used by "Yesod.Test" to provide exception-safe
+-- environment between requests and assertions.
+--
+-- This module is internal. Breaking changes to this module will not be
+-- reflected in the major version of this package.
+--
+-- @since 1.6.13
+module Yesod.Test.Internal.SIO where
+
+import Control.Monad.Trans.Reader (ReaderT (..))
+import Conduit (MonadThrow)
+import qualified Control.Monad.State.Class as MS
+import Yesod.Core
+import Data.IORef
+
+-- | State + IO
+--
+-- @since 1.6.0
+newtype SIO s a = SIO (ReaderT (IORef s) IO a)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
+
+instance MS.MonadState s (SIO s)
+  where
+  get = getSIO
+  put = putSIO
+
+-- | Retrieve the current state in the 'SIO' type.
+--
+-- Equivalent to 'MS.get'
+--
+-- @since 1.6.13
+getSIO :: SIO s s
+getSIO = SIO $ ReaderT readIORef
+
+-- | Put the given @s@ into the 'SIO' state for later retrieval.
+--
+-- Equivalent to 'MS.put', but the value is evaluated to weak head normal
+-- form.
+--
+-- @since 1.6.13
+putSIO :: s -> SIO s ()
+putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
+
+-- | Modify the underlying @s@ state.
+--
+-- This is strict in the function used, and is equivalent to 'MS.modify''.
+--
+-- @since 1.6.13
+modifySIO :: (s -> s) -> SIO s ()
+modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
+
+-- | Run an 'SIO' action with the intial state @s@ provided, returning the
+-- result, and discard the final state.
+--
+-- @since 1.6.13
+evalSIO :: SIO s a -> s -> IO a
+evalSIO action =
+    fmap snd . runSIO action
+
+-- | Run an 'SIO' action with the initial state @s@ provided, returning the
+-- final state, and discarding the result.
+--
+-- @since 1.6.13
+execSIO :: SIO s () -> s -> IO s
+execSIO action =
+    fmap fst . runSIO action
+
+-- | Run an 'SIO' action with the initial state provided, returning both
+-- the result of the computation as well as the final state.
+--
+-- @since 1.6.13
+runSIO :: SIO s a -> s -> IO (s, a)
+runSIO (SIO (ReaderT f)) s = do
+    ref <- newIORef s
+    a <- f ref
+    s' <- readIORef ref
+    pure (s', a)

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.6.12
+version:            1.6.13
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <nubis@woobiz.com.ar>
@@ -46,6 +46,7 @@ library
                      Yesod.Test.CssQuery
                      Yesod.Test.TransversingCSS
                      Yesod.Test.Internal
+                     Yesod.Test.Internal.SIO
     ghc-options:  -Wall
 
 test-suite test