{-# LANGUAGE CPP #-}
module TH.FixQ (fixQ) where
#if MIN_VERSION_template_haskell(2,17,0)
import Control.Monad.Fix (mfix)
import Language.Haskell.TH.Syntax (Q (..))
fixQ :: (a -> Q a) -> Q a
fixQ = mfix
#else
import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
import Control.Exception.Base (FixIOException (..))
import Language.Haskell.TH.Syntax (Q (..), runIO)
import GHC.IO.Unsafe (unsafeDupableInterleaveIO)
fixQ :: (a -> Q a) -> Q a
fixQ :: (a -> Q a) -> Q a
fixQ a -> Q a
k = do
MVar a
m <- IO (MVar a) -> Q (MVar a)
forall a. IO a -> Q a
runIO IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
a
ans <- IO a -> Q a
forall a. IO a -> Q a
runIO (IO a -> IO a
forall a. IO a -> IO a
unsafeDupableInterleaveIO
(MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
m IO a -> (BlockedIndefinitelyOnMVar -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
FixIOException -> IO a
forall e a. Exception e => e -> IO a
throwIO FixIOException
FixIOException))
a
result <- a -> Q a
k a
ans
IO () -> Q ()
forall a. IO a -> Q a
runIO (MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
result)
a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
#endif