diff options
| author | David Feuer <david.feuer@gmail.com> | 2017-11-02 12:06:56 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-11-02 13:20:26 -0400 |
| commit | b938576d151731b85314987fc550c17cfe824178 (patch) | |
| tree | 3cda2f27bd490c45cfad3f231e1e0be183cb53a4 /libraries | |
| parent | e0df569f7619dbef266139b9a6fa3ee9f632ea6e (diff) | |
| download | haskell-b938576d151731b85314987fc550c17cfe824178.tar.gz | |
Add custom exception for fixIO
Traditionally, `fixIO f` throws `BlockedIndefinitelyOnMVar` if
`f` is strict. This is not particularly friendly, since the
`MVar` in question is just part of the way `fixIO` happens to be
implemented. Instead, throw a new `FixIOException` with a better
explanation of the problem.
Reviewers: austin, hvr, bgamari
Subscribers: rwbarton, thomie
GHC Trac Issues: #14356
Differential Revision: https://phabricator.haskell.org/D4113
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/base/Control/Exception/Base.hs | 1 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Exception.hs | 10 | ||||
| -rw-r--r-- | libraries/base/System/IO.hs | 7 |
3 files changed, 17 insertions, 1 deletions
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index a15cc8ed32..d443159cb3 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -30,6 +30,7 @@ module Control.Exception.Base ( NonTermination(..), NestedAtomically(..), BlockedIndefinitelyOnMVar(..), + FixIOException (..), BlockedIndefinitelyOnSTM(..), AllocationLimitExceeded(..), CompactionFailed(..), diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 9203f46828..020bc067df 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -33,6 +33,7 @@ module GHC.IO.Exception ( ArrayException(..), ExitCode(..), + FixIOException (..), ioException, ioError, @@ -268,6 +269,15 @@ instance Show ArrayException where . (if not (null s) then showString ": " . showString s else id) +-- | @since TODO +data FixIOException = FixIOException + +-- | @since TODO +instance Exception FixIOException + +instance Show FixIOException where + showsPrec _ FixIOException = showString "cyclic evaluation in fixIO" + -- ----------------------------------------------------------------------------- -- The ExitCode type diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index fde5bb66e5..68817247d2 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -400,10 +400,15 @@ withBinaryFile name mode = bracket (openBinaryFile name mode) hClose -- --------------------------------------------------------------------------- -- fixIO +-- | The implementation of 'mfix' for 'IO'. If the function passed +-- to 'fixIO' inspects its argument, the resulting action will throw +-- 'FixIOException'. fixIO :: (a -> IO a) -> IO a fixIO k = do m <- newEmptyMVar - ans <- unsafeDupableInterleaveIO (readMVar m) + ans <- unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO FixIOException) result <- k ans putMVar m result return result |