From 9f09b608eecf07ad6c27729f7b6f74aca4e17e6c Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Wed, 10 Jun 2020 21:56:55 +0300
Subject: Fix #12073: Add MonadFix Q instance

---
 libraries/base/System/IO.hs                        |  5 +++-
 .../template-haskell/Language/Haskell/TH/Syntax.hs | 22 +++++++++++++++
 libraries/template-haskell/changelog.md            |  2 ++
 testsuite/tests/th/T12073.hs                       | 33 ++++++++++++++++++++++
 testsuite/tests/th/T12073.stdout                   |  2 ++
 testsuite/tests/th/all.T                           |  1 +
 6 files changed, 64 insertions(+), 1 deletion(-)
 create mode 100644 testsuite/tests/th/T12073.hs
 create mode 100644 testsuite/tests/th/T12073.stdout

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
diff --git a/testsuite/tests/th/T12073.hs b/testsuite/tests/th/T12073.hs
new file mode 100644
index 0000000000..2af76a6730
--- /dev/null
+++ b/testsuite/tests/th/T12073.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Control.Monad.Fix
+import Language.Haskell.TH
+import Control.Monad.State
+
+-- Direct variant
+$([d|
+  f1, f2 :: Integer -> [Integer]
+  f1 = \z -> z : f2 (succ z)
+  f2 = \z -> z : f1 (z * z)
+  |])
+
+-- Using mfix.
+-- This is a contrived example, but it fits into a single splice
+$(fmap (\(x,x',y,y') ->
+    [ ValD (VarP x') (NormalB x) []
+    , ValD (VarP y') (NormalB y) []
+    ]) $
+  mfix $ \ ~(_,x',_,y') -> do
+    x <- [| \z -> z : $(return $ VarE y') (succ z) |]
+    y <- [| \z -> z : $(return $ VarE x') (z * z)  |]
+    x'' <- newName "g1"
+    y'' <- newName "g2"
+    return (x, x'', y, y'')
+ )
+
+
+main :: IO ()
+main = do
+    print $ take 11 $ f1 0
+    print $ take 11 $ g1 0
diff --git a/testsuite/tests/th/T12073.stdout b/testsuite/tests/th/T12073.stdout
new file mode 100644
index 0000000000..15c42f3745
--- /dev/null
+++ b/testsuite/tests/th/T12073.stdout
@@ -0,0 +1,2 @@
+[0,1,1,2,4,5,25,26,676,677,458329]
+[0,1,1,2,4,5,25,26,676,677,458329]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 83844ad396..46fbcf7073 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -364,6 +364,7 @@ test('T11629', normal, compile, ['-v0'])
 test('T8761', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T12045TH1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T12045TH2', normal, compile, ['-v0'])
+test('T12073', normal, compile_and_run, [''])
 test('T12130', [], multimod_compile,
      ['T12130', '-v0 ' + config.ghc_th_way_flags])
 test('T12387', normal, compile_fail, ['-v0'])
-- 
cgit v1.2.1