[commit: ghc] master: Add custom exception for fixIO (b938576)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b938576d151731b85314987fc550c17cfe824178/ghc

>---------------------------------------------------------------

commit b938576d151731b85314987fc550c17cfe824178
Author: David Feuer <david.feuer at gmail.com>
Date:   Thu Nov 2 12:06:56 2017 -0400

    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


>---------------------------------------------------------------

b938576d151731b85314987fc550c17cfe824178
 libraries/base/Control/Exception/Base.hs               |  1 +
 libraries/base/GHC/IO/Exception.hs                     | 10 ++++++++++
 libraries/base/System/IO.hs                            |  7 ++++++-
 testsuite/tests/mdo/should_fail/mdofail006.stderr      |  2 +-
 testsuite/tests/typecheck/should_compile/holes2.stderr |  2 +-
 5 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index a15cc8e..d443159 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 9203f46..020bc06 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 fde5bb6..6881724 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
diff --git a/testsuite/tests/mdo/should_fail/mdofail006.stderr b/testsuite/tests/mdo/should_fail/mdofail006.stderr
index ea186c0..e2cf503 100644
--- a/testsuite/tests/mdo/should_fail/mdofail006.stderr
+++ b/testsuite/tests/mdo/should_fail/mdofail006.stderr
@@ -1 +1 @@
-mdofail006: thread blocked indefinitely in an MVar operation
+mdofail006: cyclic evaluation in fixIO
diff --git a/testsuite/tests/typecheck/should_compile/holes2.stderr b/testsuite/tests/typecheck/should_compile/holes2.stderr
index d7484fa..fd3073d 100644
--- a/testsuite/tests/typecheck/should_compile/holes2.stderr
+++ b/testsuite/tests/typecheck/should_compile/holes2.stderr
@@ -9,7 +9,7 @@ holes2.hs:3:5: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 61 instances involving out-of-scope types
+        ...plus 62 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show _
       In an equation for ‘f’: f = show _