Commit 9f09b608 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by Marge Bot
Browse files

Fix #12073: Add MonadFix Q instance

parent 87d504f4
......@@ -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.
--
......
......@@ -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
......
......@@ -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
......
{-# 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
[0,1,1,2,4,5,25,26,676,677,458329]
[0,1,1,2,4,5,25,26,676,677,458329]
......@@ -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'])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment