{-# LANGUAGE CPP #-}
-- | A compat module to take fixed points in 'Q'.
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

-- We don't have a MonadFix instance for Q
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