Fix #12073: Add MonadFix Q instance

3 files changed, 28 insertions, 1 deletions

diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index 4f3693a872..a4d4ec4e67 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -440,7 +440,10 @@ fixIO k = do
     putMVar m result
     return result
 
--- NOTE: we do our own explicit black holing here, because GHC's lazy
+-- Note [Blackholing in fixIO]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We do our own explicit black holing here, because GHC's lazy
 -- blackholing isn't enough.  In an infinite loop, GHC may run the IO
 -- computation a few times before it notices the loop, which is wrong.
 --
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 6555380878..b1b40c7951 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -31,9 +31,14 @@ module Language.Haskell.TH.Syntax
 import Data.Data hiding (Fixity(..))
 import Data.IORef
 import System.IO.Unsafe ( unsafePerformIO )
+import GHC.IO.Unsafe    ( unsafeDupableInterleaveIO )
 import Control.Monad (liftM)
 import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Fix (MonadFix (..))
 import Control.Applicative (liftA2)
+import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
+import Control.Exception.Base (FixIOException (..))
+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
 import System.IO        ( hPutStrLn, stderr )
 import Data.Char        ( isAlpha, isAlphaNum, isUpper, ord )
 import Data.Int
@@ -215,6 +220,23 @@ instance Semigroup a => Semigroup (Q a) where
 instance Monoid a => Monoid (Q a) where
   mempty = pure mempty
 
+-- | If the function passed to 'mfix' inspects its argument,
+-- the resulting action will throw a 'FixIOException'.
+--
+-- @since 2.17.0.0
+instance MonadFix Q where
+  -- We use the same blackholing approach as in fixIO.
+  -- See Note [Blackholing in fixIO] in System.IO in base.
+  mfix k = do
+    m <- runIO newEmptyMVar
+    ans <- runIO (unsafeDupableInterleaveIO
+             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
+                                    throwIO FixIOException))
+    result <- k ans
+    runIO (putMVar m result)
+    return result
+
+
 -----------------------------------------------------
 --
 --              The Quote class
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 24a74e4616..d3eaa00b4c 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -24,6 +24,8 @@
 
   * Add `Semigroup` and `Monoid` instances for `Q` (#18123).
 
+  * Add `MonadFix` instance for `Q` (#12073).
+
 ## 2.16.0.0 *TBA*
 
   * Add support for tuple sections. (#15843) The type signatures of `TupE` and