GitLab

Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC

Commits:

8bb87c2c

by Teo Camarasu at 2026-06-25T18:09:17+01:00

Make Q abstract

This patch aims to clearly demarcate the internal and external interfaces
of Q.
In the past the `Quasi` typeclass was both part of the external,
public-facing interface, and was used to give the implementation of `Q`.

Now we separate out these two distinct roles. `Quasi` continues to exist
in the public interface, but we introduce a new `MetaHandlers` type,
which is equivalent to `Dict Quasi`.

`Q a` is now defined to be `MetaHandlers -> IO a`, and, crucially,
the constructor and the new `MetaHandlers` type are not exposed from the
public interface.

This gives us the ability to vary the interface on the GHC side without
forcing a breaking change on the `template-haskell` side.
Similarly `template-haskell` has more freedom to change the `Quasi`
typeclass without needing any changes in `lib:ghc`.

Implements https://github.com/ghc-proposals/ghc-proposals/pull/700

Resolves #27341

9 changed files:

+ changelog.d/AbstractQ
compiler/GHC/Data/IOEnv.hs
compiler/GHC/Tc/Gen/Splice.hs
compiler/GHC/Tc/Gen/Splice.hs-boot
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
libraries/ghci/GHCi/TH.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/interface-stability/template-haskell-exports.stdout

Changes:

changelog.d/AbstractQ

 +section: template-haskell
 +synopsis: Hide the implementation of Q
 +description: The constructor of Q is now hidden.
 +  This is done to improve the stability of ``template-haskell``.
 +  To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``.
 +  The ``Quasi TcM`` instance is no longer exposed from the ``ghc`` API.
 +  See the `GHC proposal <https://github.com/ghc-proposals/ghc-proposals/pull/700>`_ for more details.
 +mrs: !15696
 +issues: #27341

compiler/GHC/Data/IOEnv.hs

@@ -22,7 +22,7 @@ module GHC.Data.IOEnv (
          IOEnvFailure(..),
          -- Getting at the environment
 -        getEnv, setEnv, updEnv, updEnvIO,
 +        getEnv, setEnv, updEnv, updEnvIO, withRunInIO,
          runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
          tryM, tryAllM, tryMostM, fixM,
@@ -258,3 +258,12 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
  updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a
  {-# INLINE updEnvIO #-}
  updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
++
 +-- | 'withRunInIO' specialised to `IOEnv`.
 +--   See https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unlift.html#v:withRunInIO for an explanation.
 +withRunInIO:: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
 +withRunInIO k = IOEnv $ \env ->
 +  let
 +    unlift :: forall a. IOEnv env a -> IO a
 +    unlift (IOEnv m) = m env
 +  in k unlift

compiler/GHC/Tc/Gen/Splice.hs

@@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice(
       tcTypedSplice, tcTypedBracket, tcUntypedBracket,
       runAnnotation, getUntypedSpliceBody,
 -     runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
 +     runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM,
       tcTopSpliceExpr, lookupThName_maybe,
       defaultRunMeta, runMeta', runRemoteModFinalizers,
       finishTH, runTopSplice
@@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt
  -- THSyntax gives access to internal functions and data types
  import qualified GHC.Boot.TH.Syntax as TH
  import qualified GHC.Boot.TH.Monad  as TH
 +import GHC.Boot.TH.Monad  (MetaHandlers(..))
  import qualified GHC.Boot.TH.Ppr    as TH
  #if defined(HAVE_INTERNAL_INTERPRETER)
@@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do
  ************************************************************************
  -}
 -runQuasi :: TH.Q a -> TcM a
 -runQuasi act = TH.runQ act
 +runQinTcM :: TH.Q a -> TcM a
 +runQinTcM (TH.Q act) = withRunInIO $ \runInIO -> act (metaHandlersTcM runInIO)
  runRemoteModFinalizers :: ThModFinalizers -> TcM ()
  runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
  #if defined(HAVE_INTERNAL_INTERPRETER)
      InternalInterp -> do
        qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
 -      runQuasi $ sequence_ qs
 +      runQinTcM $ sequence_ qs
  #endif
      ExternalInterp ext -> withExtInterp ext $ \inst -> do
@@ -1466,70 +1467,14 @@ when showing an error message.
  To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
  -}
 -instance TH.Quasi TcM where
 -  qNewName s = do { u <- newUnique
 -                  ; let i = toInteger (getKey u)
 -                  ; return (TH.mkNameU s i) }
 +-- 'msg' is forced to ensure exceptions don't escape,
 +-- see Note [Exceptions in TH]
 +report :: Bool -> [Char] -> TcM ()
 +report True msg  = seqList msg $ addErr        $ TcRnTHError $ ReportCustomQuasiError True  msg
 +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
 -  -- 'msg' is forced to ensure exceptions don't escape,
 -  -- see Note [Exceptions in TH]
 -  qReport True msg  = seqList msg $ addErr        $ TcRnTHError $ ReportCustomQuasiError True  msg
 -  qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
+-
 -  qLocation :: TcM TH.Loc
 -  qLocation = do { m <- getModule
 -                 ; l <- getSrcSpanM
 -                 ; r <- case l of
 -                        RealSrcSpan s _ -> return s
 -                        GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
 -                                                    (pprGeneratedSrcSpanDetails)
 -                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
 -                                                    (ppr l)
 -                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
 -                                  , TH.loc_module   = moduleNameString (moduleName m)
 -                                  , TH.loc_package  = unitString (moduleUnit m)
 -                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
 -                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
+-
 -  qLookupName       = lookupName
 -  qReify            = reify
 -  qReifyFixity nm   = lookupThName nm >>= reifyFixity
 -  qReifyType        = reifyTypeOfThing
 -  qReifyInstances   = reifyInstances
 -  qReifyRoles       = reifyRoles
 -  qReifyAnnotations = reifyAnnotations
 -  qReifyModule      = reifyModule
 -  qReifyConStrictness nm = do { nm' <- lookupThName nm
 -                              ; dc  <- tcLookupDataCon nm'
 -                              ; let bangs = dataConImplBangs dc
 -                              ; return (map reifyDecidedStrictness bangs) }
+-
 -        -- For qRecover, discard error messages if
 -        -- the recovery action is chosen.  Otherwise
 -        -- we'll only fail higher up.
 -  qRecover recover main = tryTcDiscardingErrs recover main
+-
 -  qGetPackageRoot = do
 -    dflags <- getDynFlags
 -    return $ fromMaybe "." (workingDirectory dflags)
+-
 -  qAddDependentFile fp = do
 -    ref <- fmap tcg_dependent_files getGblEnv
 -    dep_files <- readTcRef ref
 -    writeTcRef ref (fp:dep_files)
+-
 -  qAddDependentDirectory dp = do
 -    ref <- fmap tcg_dependent_dirs getGblEnv
 -    dep_dirs <- readTcRef ref
 -    writeTcRef ref (dp:dep_dirs)
+-
 -  qAddTempFile suffix = do
 -    dflags <- getDynFlags
 -    logger <- getLogger
 -    tmpfs  <- hsc_tmpfs <$> getTopEnv
 -    liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
+-
 -  qAddTopDecls thds = do
 +addTopDecls :: [TH.Dec] -> TcM ()
 +addTopDecls thds = do
        exts <- fmap extensionFlags getDynFlags
        l <- getSrcSpanM
        th_origin <- getThSpliceOrigin
@@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where
        bindName :: RdrName -> TcM ()
        bindName (Exact n)
          = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
 -             ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
 -             }
 +            ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
 +            }
        bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name
 -  qAddForeignFilePath lang fp = do
 -    var <- fmap tcg_th_foreign_files getGblEnv
 -    updTcRef var ((lang, fp) :)
+-
 -  qAddModFinalizer fin = do
 -      r <- liftIO $ mkRemoteRef fin
 -      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
 -      addModFinalizerRef fref
+-
 -  qAddCorePlugin plugin = do
 -      hsc_env <- getTopEnv
 -      let fc        = hsc_FC hsc_env
 -      let home_unit = hsc_home_unit hsc_env
 -      let dflags    = hsc_dflags hsc_env
 -      let fopts     = initFinderOpts dflags
 -      r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
 -      let err = TcRnTHError $ AddInvalidCorePlugin plugin
 -      case r of
 -        Found {} -> addErr err
 -        FoundMultiple {} -> addErr err
 -        _ -> return ()
 -      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
 -      updTcRef th_coreplugins_var (plugin:)
+-
 -  qGetQ :: forall a. Typeable a => TcM (Maybe a)
 -  qGetQ = do
 -      th_state_var <- fmap tcg_th_state getGblEnv
 -      th_state <- readTcRef th_state_var
 -      -- See #10596 for why we use a scoped type variable here.
 -      return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+-
 -  qPutQ x = do
 -      th_state_var <- fmap tcg_th_state getGblEnv
 -      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+-
 -  qIsExtEnabled = xoptM
+-
 -  qExtsEnabled =
 -    EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+-
 -  qPutDoc doc_loc s = do
 +putDoc :: TH.DocLoc -> String -> TcM ()
 +putDoc doc_loc s = do
      th_doc_var <- tcg_th_docs <$> getGblEnv
      resolved_doc_loc <- resolve_loc doc_loc
      is_local <- checkLocalName resolved_doc_loc
@@ -1624,15 +1530,131 @@ instance TH.Quasi TcM where
        checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
        checkLocalName ModuleDoc = pure True
+-
 -  qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
 -  qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
 -  qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
 -  qGetDoc TH.ModuleDoc = do
 +getDoc :: TH.DocLoc -> TcM (Maybe String)
 +getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
 +getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
 +getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
 +getDoc TH.ModuleDoc = do
      df <- getDynFlags
      docs <- getGblEnv >>= extractDocs df
      return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
 +getQ :: forall a. Typeable a => TcM (Maybe a)
 +getQ = do
 +    th_state_var <- fmap tcg_th_state getGblEnv
 +    th_state <- readTcRef th_state_var
 +    -- See #10596 for why we use a scoped type variable here.
 +    return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
++
 +location :: TcM TH.Loc
 +location = do { m <- getModule
 +              ; l <- getSrcSpanM
 +              ; r <- case l of
 +                        RealSrcSpan s _ -> return s
 +                        GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan"
 +                                                    (pprGeneratedSrcSpanDetails)
 +                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
 +                                                    (ppr l)
 +              ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
 +                               , TH.loc_module   = moduleNameString (moduleName m)
 +                               , TH.loc_package  = unitString (moduleUnit m)
 +                               , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
 +                               , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
++
 +metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers
 +metaHandlersTcM runInIO = TH.MetaHandlers {
 +      mLiftIO = id
 +    -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error.
 +    , mFail = \s -> runInIO $ fail @TcM s
 +    , mNewName = \s -> runInIO $ do { u <- newUnique
 +                      ; let i = toInteger (getKey u)
 +                      ; return (TH.mkNameU s i) }
++
 +    , mReport = fmap runInIO . report
++
 +    , mLocation = runInIO location
++
 +    , mLookupName       = fmap runInIO . lookupName
 +    , mReify            = runInIO . reify
 +    , mReifyFixity      = \nm -> runInIO $ lookupThName nm >>= reifyFixity
 +    , mReifyType        = runInIO . reifyTypeOfThing
 +    , mReifyInstances   = fmap runInIO . reifyInstances
 +    , mReifyRoles       = runInIO . reifyRoles
 +    , mReifyAnnotations = runInIO . reifyAnnotations
 +    , mReifyModule      = runInIO . reifyModule
 +    , mReifyConStrictness = \nm -> runInIO $ do
 +                                      { nm' <- lookupThName nm
 +                                      ; dc  <- tcLookupDataCon nm'
 +                                      ; let bangs = dataConImplBangs dc
 +                                      ; return (map reifyDecidedStrictness bangs) }
++
 +    -- For qRecover, discard error messages if
 +    -- the recovery action is chosen.  Otherwise
 +    -- we'll only fail higher up.
 +    , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main)
++
 +    , mGetPackageRoot = runInIO $ do
 +        dflags <- getDynFlags
 +        return $ fromMaybe "." (workingDirectory dflags)
++
 +    , mAddDependentFile = \fp -> runInIO $ do
 +        ref <- fmap tcg_dependent_files getGblEnv
 +        dep_files <- readTcRef ref
 +        writeTcRef ref (fp:dep_files)
++
 +    , mAddDependentDirectory = \dp -> runInIO $ do
 +        ref <- fmap tcg_dependent_dirs getGblEnv
 +        dep_dirs <- readTcRef ref
 +        writeTcRef ref (dp:dep_dirs)
++
 +    , mAddTempFile = \suffix -> runInIO $ do
 +        dflags <- getDynFlags
 +        logger <- getLogger
 +        tmpfs  <- hsc_tmpfs <$> getTopEnv
 +        liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
++
 +    , mAddTopDecls = runInIO . addTopDecls
++
 +    , mAddForeignFilePath = \lang fp -> runInIO $ do
 +        var <- fmap tcg_th_foreign_files getGblEnv
 +        updTcRef var ((lang, fp) :)
++
 +    , mAddModFinalizer = \fin -> runInIO $ do
 +        r <- liftIO $ mkRemoteRef fin
 +        fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
 +        addModFinalizerRef fref
++
 +    , mAddCorePlugin = \plugin -> runInIO $ do
 +        hsc_env <- getTopEnv
 +        let fc        = hsc_FC hsc_env
 +        let home_unit = hsc_home_unit hsc_env
 +        let dflags    = hsc_dflags hsc_env
 +        let fopts     = initFinderOpts dflags
 +        r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
 +        let err = TcRnTHError $ AddInvalidCorePlugin plugin
 +        case r of
 +          Found {} -> addErr err
 +          FoundMultiple {} -> addErr err
 +          _ -> return ()
 +        th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
 +        updTcRef th_coreplugins_var (plugin:)
++
 +    , mGetQ = runInIO getQ
++
 +    , mPutQ = \x -> runInIO $ do
 +        th_state_var <- fmap tcg_th_state getGblEnv
 +        updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
++
 +    , mIsExtEnabled = runInIO . xoptM
++
 +    , mExtsEnabled = runInIO $
 +        EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
++
 +    , mPutDoc = fmap runInIO . putDoc
++
 +    , mGetDoc = runInIO . getDoc
 +  }
++
  -- | Looks up documentation for a declaration in first the current module,
  -- otherwise tries to find it in another module via 'hscGetModuleInterface'.
  lookupDeclDoc :: Name -> TcM (Maybe String)
@@ -1788,7 +1810,7 @@ runTH ty fhv = do
      InternalInterp -> do
         -- Run it in the local TcM
        hv <- liftIO $ wormhole interp fhv
 -      r <- runQuasi (unsafeCoerce hv :: TH.Q a)
 +      r <- runQinTcM (unsafeCoerce hv :: TH.Q a)
        return r
  #endif
@@ -1797,7 +1819,7 @@ runTH ty fhv = do
        -- Remote GHCi, see Note [Remote Template Haskell] in
        -- libraries/ghci/GHCi/TH.hs.
        rstate <- getTHState inst
 -      loc <- TH.qLocation
 +      loc <- location
        -- run a remote TH request
        r <- liftIO $
          withForeignRef rstate $ \state_hv ->
@@ -1913,32 +1935,32 @@ wrapTHResult tcm = do
  handleTHMessage :: THMessage a -> TcM a
  handleTHMessage msg = case msg of
 -  NewName a -> wrapTHResult $ TH.qNewName a
 -  Report b str -> wrapTHResult $ TH.qReport b str
 -  LookupName b str -> wrapTHResult $ TH.qLookupName b str
 -  Reify n -> wrapTHResult $ TH.qReify n
 -  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
 -  ReifyType n -> wrapTHResult $ TH.qReifyType n
 -  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
 -  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
 +  NewName a -> wrapTHResult $ runQinTcM $ TH.newName a
 +  Report b str -> wrapTHResult $ runQinTcM $ TH.report b str
 +  LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str
 +  Reify n -> wrapTHResult $ runQinTcM $ TH.reify n
 +  ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n
 +  ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n
 +  ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
 +  ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
    ReifyAnnotations lookup tyrep ->
      wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
 -  ReifyModule m -> wrapTHResult $ TH.qReifyModule m
 -  ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
 -  GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
 -  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
 -  AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
 -  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
 +  ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
 +  ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
 +  GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
 +  AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f
 +  AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d
 +  AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s
    AddModFinalizer r -> do
      interp <- hscInterp <$> getTopEnv
      wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
 -  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
 -  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
 -  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
 -  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
 -  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
 -  PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
 -  GetDoc l -> wrapTHResult $ TH.qGetDoc l
 +  AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str
 +  AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs
 +  AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str
 +  IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext
 +  ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled
 +  PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s
 +  GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l
    FailIfErrs -> wrapTHResult failIfErrsM
    _ -> panic ("handleTHMessage: unexpected message " ++ show msg)

compiler/GHC/Tc/Gen/Splice.hs-boot

@@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)
  runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
  lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
 -runQuasi :: TH.Q a -> TcM a
 +runQinTcM :: TH.Q a -> TcM a
  runRemoteModFinalizers :: ThModFinalizers -> TcM ()
  finishTH :: TcM ()

libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs

@@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec
  withDecDoc doc dec = do
    dec' <- dec
    case doc_loc dec' of
 -    Just loc -> qAddModFinalizer $ qPutDoc loc doc
 +    Just loc -> addModFinalizer $ putDoc loc doc
      Nothing  -> pure ()
    pure dec'
    where
@@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause]
           -> [Maybe String] -- ^ Documentation to attach to arguments
           -> Q Dec
  funD_doc nm cs mfun_doc arg_docs = do
 -  qAddModFinalizer $ sequence_
 +  addModFinalizer $ sequence_
      [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
    let dec = funD nm cs
    case mfun_doc of
@@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
            -- ^ Documentation to attach to the data declaration
            -> Q Dec
  dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
 -  qAddModFinalizer $ mapM_ docCons cons_with_docs
 +  addModFinalizer $ mapM_ docCons cons_with_docs
    let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
    maybe dec (flip withDecDoc dec) mdoc
@@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
               -- ^ Documentation to attach to the newtype declaration
               -> Q Dec
  newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
 -  qAddModFinalizer $ docCons con_with_docs
 +  addModFinalizer $ docCons con_with_docs
    let dec = newtypeD ctxt tc tvs ksig con derivs
    maybe dec (flip withDecDoc dec) mdoc
@@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
            -- ^ Documentation to attach to the data declaration
            -> Q Dec
  typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
 -  qAddModFinalizer $ mapM_ docCons cons_with_docs
 +  addModFinalizer $ mapM_ docCons cons_with_docs
    let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
    maybe dec (flip withDecDoc dec) mdoc
@@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
                -- ^ Documentation to attach to the instance declaration
                -> Q Dec
  dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
 -  qAddModFinalizer $ mapM_ docCons cons_with_docs
 +  addModFinalizer $ mapM_ docCons cons_with_docs
    let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
                derivs
    maybe dec (flip withDecDoc dec) mdoc
@@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
                   -- ^ Documentation to attach to the instance declaration
                   -> Q Dec
  newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
 -  qAddModFinalizer $ docCons con_with_docs
 +  addModFinalizer $ docCons con_with_docs
    let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
    maybe dec (flip withDecDoc dec) mdoc
@@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
              -> [Maybe String] -- ^ Documentation to attach to the pattern arguments
              -> Q Dec
  patSynD_doc name args dir pat mdoc arg_docs = do
 -  qAddModFinalizer $ sequence_
 +  addModFinalizer $ sequence_
      [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
    let dec = patSynD name args dir pat
    maybe dec (flip withDecDoc dec) mdoc

libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs

@@ -29,13 +29,13 @@ import Data.Data hiding (Fixity(..))
  import Data.IORef
  import System.IO.Unsafe (unsafePerformIO)
  import Control.Monad.IO.Class (MonadIO (..))
 -import System.IO (FilePath, hPutStrLn, stderr)
 +import System.IO (hPutStrLn, stderr)
  import qualified Data.Kind as Kind (Type)
  import GHC.Types (TYPE, RuntimeRep(..))
  #else
  import GHC.Internal.Base (
      Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String,
 -    flip, id, (.), (++),
 +    flip, id, (.), (++), ($),
+   )
  import GHC.Internal.Classes (not)
  import GHC.Internal.Data.Data hiding (Fixity(..))
@@ -59,145 +59,150 @@ import GHC.Internal.ForeignSrcLang
  import GHC.Internal.LanguageExtensions
  import GHC.Internal.TH.Syntax
 ------------------------------------------------------
 ---
 ---              The Quasi class
 ---
 ------------------------------------------------------
+-
 -class (MonadIO m, MonadFail m) => Quasi m where
 -  -- | Fresh names. See 'newName'.
 -  qNewName :: String -> m Name
+-
 -  ------- Error reporting and recovery -------
 -  -- | Report an error (True) or warning (False)
 -  -- ...but carry on; use 'fail' to stop. See 'report'.
 -  qReport  :: Bool -> String -> m ()
+-
 -  -- | See 'recover'.
 -  qRecover :: m a -- ^ the error handler
 -           -> m a -- ^ action which may fail
 -           -> m a -- ^ Recover from the monadic 'fail'
+-
 -  ------- Inspect the type-checker's environment -------
 -  -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
 -  qLookupName :: Bool -> String -> m (Maybe Name)
 -  -- | See 'reify'.
 -  qReify          :: Name -> m Info
 -  -- | See 'reifyFixity'.
 -  qReifyFixity    :: Name -> m (Maybe Fixity)
 -  -- | See 'reifyType'.
 -  qReifyType      :: Name -> m Type
 -  -- | Is (n tys) an instance? Returns list of matching instance Decs (with
 -  -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
 -  qReifyInstances :: Name -> [Type] -> m [Dec]
 -  -- | See 'reifyRoles'.
 -  qReifyRoles         :: Name -> m [Role]
 -  -- | See 'reifyAnnotations'.
 -  qReifyAnnotations   :: Data a => AnnLookup -> m [a]
 -  -- | See 'reifyModule'.
 -  qReifyModule        :: Module -> m ModuleInfo
 -  -- | See 'reifyConStrictness'.
 -  qReifyConStrictness :: Name -> m [DecidedStrictness]
+-
 -  -- | See 'location'.
 -  qLocation :: m Loc
+-
 -  -- | Input/output (dangerous). See 'runIO'.
 -  qRunIO :: IO a -> m a
 -  qRunIO = liftIO
 -  -- | See 'getPackageRoot'.
 -  qGetPackageRoot :: m FilePath
+-
 -  -- | See 'addDependentFile'.
 -  qAddDependentFile :: FilePath -> m ()
+-
 -  -- | See 'addDependentDirectory'.
 -  qAddDependentDirectory :: FilePath -> m ()
+-
 -  -- | See 'addTempFile'.
 -  qAddTempFile :: String -> m FilePath
+-
 -  -- | See 'addTopDecls'.
 -  qAddTopDecls :: [Dec] -> m ()
+-
 -  -- | See 'addForeignFilePath'.
 -  qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
+-
 -  -- | See 'addModFinalizer'.
 -  qAddModFinalizer :: Q () -> m ()
+-
 -  -- | See 'addCorePlugin'.
 -  qAddCorePlugin :: String -> m ()
+-
 -  -- | See 'getQ'.
 -  qGetQ :: Typeable a => m (Maybe a)
+-
 -  -- | See 'putQ'.
 -  qPutQ :: Typeable a => a -> m ()
+-
 -  -- | See 'isExtEnabled'.
 -  qIsExtEnabled :: Extension -> m Bool
 -  -- | See 'extsEnabled'.
 -  qExtsEnabled :: m [Extension]
+-
 -  -- | See 'putDoc'.
 -  qPutDoc :: DocLoc -> String -> m ()
 -  -- | See 'getDoc'.
 -  qGetDoc :: DocLoc -> m (Maybe String)
 +-- | 'MetaHandlers' defines the interface between GHC and TH splices.
 +-- This is an internal interface between two parts of the compiler,
 +-- and should never be directly exposed to users.
 +--
 +-- It mirrors the 'Quasi' typeclass, which is part of the public facing interface of TH.
 +-- With time the two interfaces may drift apart.
 +--
 +-- This type is defined in `ghc-internal` rather than `lib:ghc` to avoid
 +-- `template-haskell` having to depend on GHC, ie, it implements dependency inversion.
 +--
 +-- For more information about the historical design of this interface,
 +-- see: https://github.com/ghc-proposals/ghc-proposals/pull/700
 +data MetaHandlers = MetaHandlers {
 +    -- | We have an explicit handler for liftIO to allow users to forbid lifting into 'IO'
 +      mLiftIO :: forall a. IO a -> IO a
 +    , mFail :: forall a. String -> IO a
 +    -- | Fresh names. See 'newName'.
 +    , mNewName :: String -> IO Name
++
 +    ------- Error reporting and recovery -------
 +    -- | Report an error (True) or warning (False)
 +    -- ...but carry on; use 'fail' to stop. See 'report'.
 +    , mReport  :: Bool -> String -> IO ()
++
 +    -- | See 'recover'.
 +    , mRecover :: forall a. Q a -- ^ the error handler
 +            -> Q a -- ^ action which may fail
 +            -> IO a -- ^ Recover from the monadic 'fail'
++
 +    ------- Inspect the type-checker's environment -------
 +    -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
 +    , mLookupName :: Bool -> String -> IO (Maybe Name)
 +    -- | See 'reify'.
 +    , mReify          :: Name -> IO Info
 +    -- | See 'reifyFixity'.
 +    , mReifyFixity    :: Name -> IO (Maybe Fixity)
 +    -- | See 'reifyType'.
 +    , mReifyType      :: Name -> IO Type
 +    -- | Is (n tys) an instance? Returns list of matching instance Decs (with
 +    -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
 +    , mReifyInstances :: Name -> [Type] -> IO [Dec]
 +    -- | See 'reifyRoles'.
 +    , mReifyRoles         :: Name -> IO [Role]
 +    -- | See 'reifyAnnotations'.
 +    , mReifyAnnotations   :: forall a. Data a => AnnLookup -> IO [a]
 +    -- | See 'reifyModule'.
 +    , mReifyModule        :: Module -> IO ModuleInfo
 +    -- | See 'reifyConStrictness'.
 +    , mReifyConStrictness :: Name -> IO [DecidedStrictness]
++
 +    -- | See 'location'.
 +    , mLocation :: IO Loc
++
 +    -- | See 'getPackageRoot'.
 +    , mGetPackageRoot :: IO FilePath
++
 +    -- | See 'addDependentFile'.
 +    , mAddDependentFile :: FilePath -> IO ()
++
 +    -- | See 'addDependentDirectory'.
 +    , mAddDependentDirectory :: FilePath -> IO ()
++
 +    -- | See 'addTempFile'.
 +    , mAddTempFile :: String -> IO FilePath
++
 +    -- | See 'addTopDecls'.
 +    , mAddTopDecls :: [Dec] -> IO ()
++
 +    -- | See 'addForeignFilePath'.
 +    , mAddForeignFilePath :: ForeignSrcLang -> String -> IO ()
++
 +    -- | See 'addModFinalizer'.
 +    , mAddModFinalizer :: Q () -> IO ()
++
 +    -- | See 'addCorePlugin'.
 +    , mAddCorePlugin :: String -> IO ()
++
 +    -- | See 'getQ'.
 +    , mGetQ :: forall a. Typeable a => IO (Maybe a)
++
 +    -- | See 'putQ'.
 +    , mPutQ :: forall a. Typeable a => a -> IO ()
++
 +    -- | See 'isExtEnabled'.
 +    , mIsExtEnabled :: Extension -> IO Bool
 +    -- | See 'extsEnabled'.
 +    , mExtsEnabled :: IO [Extension]
++
 +    -- | See 'putDoc'.
 +    , mPutDoc :: DocLoc -> String -> IO ()
 +    -- | See 'getDoc'.
 +    , mGetDoc :: DocLoc -> IO (Maybe String)
 +  }
 ------------------------------------------------------
 ---      The IO instance of Quasi
 ------------------------------------------------------
 +badIO :: String -> IO a
 +badIO op = do   { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad")
 +                ; fail "Template Haskell failure" }
 ---  | This instance is used only when running a Q
 ---  computation in the IO monad, usually just to
 ---  print the result.  There is no interesting
 ---  type environment, so reification isn't going to
 ---  work.
 -instance Quasi IO where
 -  qNewName = newNameIO
+-
 -  qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
 -  qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+-
 -  qLookupName _ _       = badIO "lookupName"
 -  qReify _              = badIO "reify"
 -  qReifyFixity _        = badIO "reifyFixity"
 -  qReifyType _          = badIO "reifyFixity"
 -  qReifyInstances _ _   = badIO "reifyInstances"
 -  qReifyRoles _         = badIO "reifyRoles"
 -  qReifyAnnotations _   = badIO "reifyAnnotations"
 -  qReifyModule _        = badIO "reifyModule"
 -  qReifyConStrictness _ = badIO "reifyConStrictness"
 -  qLocation             = badIO "currentLocation"
 -  qRecover _ _          = badIO "recover" -- Maybe we could fix this?
 -  qGetPackageRoot       = badIO "getProjectRoot"
 -  qAddDependentFile _   = badIO "addDependentFile"
 -  qAddTempFile _        = badIO "addTempFile"
 -  qAddTopDecls _        = badIO "addTopDecls"
 -  qAddForeignFilePath _ _ = badIO "addForeignFilePath"
 -  qAddModFinalizer _    = badIO "addModFinalizer"
 -  qAddCorePlugin _      = badIO "addCorePlugin"
 -  qGetQ                 = badIO "getQ"
 -  qPutQ _               = badIO "putQ"
 -  qIsExtEnabled _       = badIO "isExtEnabled"
 -  qExtsEnabled          = badIO "extsEnabled"
 -  qPutDoc _ _           = badIO "putDoc"
 -  qGetDoc _             = badIO "getDoc"
 -  qAddDependentDirectory _ = badIO "AddDependentDirectory"
 +metaHandlersIO :: MetaHandlers
 +metaHandlersIO  = MetaHandlers {
 +    mLiftIO = id
 +  , mFail = fail
 +  , mNewName = newNameIO
 +  , mReport = \b msg ->
 +     if b then
 +       hPutStrLn stderr ("Template Haskell error: " ++ msg)
 +     else
 +       hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above?
 +  , mLookupName           = \ _ _ -> badIO "lookupName"
 +  , mReify                = \_ -> badIO "reify"
 +  , mReifyFixity          = \_ -> badIO "reifyFixity"
 +  , mReifyType            = \_ -> badIO "reifyFixity"
 +  , mReifyInstances       = \_ _ -> badIO "reifyInstances"
 +  , mReifyRoles           = \_ -> badIO "reifyRoles"
 +  , mReifyAnnotations     = \_ -> badIO "reifyAnnotations"
 +  , mReifyModule          = \_ -> badIO "reifyModule"
 +  , mReifyConStrictness   = \_ -> badIO "reifyConStrictness"
 +  , mLocation             = badIO "currentLocation"
 +  , mRecover              = \_ _ -> badIO "recover" -- Maybe we could fix this?
 +  , mGetPackageRoot       = badIO "getProjectRoot"
 +  , mAddDependentFile     = \_ -> badIO "addDependentFile"
 +  , mAddTempFile          = \_ -> badIO "addTempFile"
 +  , mAddTopDecls          = \_ -> badIO "addTopDecls"
 +  , mAddForeignFilePath   = \_ _ -> badIO "addForeignFilePath"
 +  , mAddModFinalizer      = \_ -> badIO "addModFinalizer"
 +  , mAddCorePlugin        = \_ -> badIO "addCorePlugin"
 +  , mGetQ                 = badIO "getQ"
 +  , mPutQ                 = \_ -> badIO "putQ"
 +  , mIsExtEnabled         = \_ -> badIO "isExtEnabled"
 +  , mExtsEnabled          = badIO "extsEnabled"
 +  , mPutDoc               = \_ _ -> badIO "putDoc"
 +  , mGetDoc               = \_ -> badIO "getDoc"
 +  , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory"
 +  }
  instance Quote IO where
    newName = newNameIO
++
++
  newNameIO :: String -> IO Name
  newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
                   ; pure (mkNameU s n) }
 -badIO :: String -> IO a
 -badIO op = do   { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
 -                ; fail "Template Haskell failure" }
+-
  -- Global variable to generate unique symbols
  counter :: IORef Uniq
  {-# NOINLINE counter #-}
@@ -210,46 +215,24 @@ counter = unsafePerformIO (newIORef 0)
  --
  -----------------------------------------------------
 --- | In short, 'Q' provides the 'Quasi' operations in one neat monad for the
 --- user.
 ---
 --- The longer story, is that 'Q' wraps an arbitrary 'Quasi'-able monad.
 --- The perceptive reader notices that 'Quasi' has only two instances, 'Q'
 --- itself and 'IO', neither of which have concrete implementations.'Q' plays
 --- the trick of [dependency
 --- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle),
 --- providing an abstract interface for the user which is later concretely
 --- fufilled by an concrete 'Quasi' instance, internal to GHC.
 -newtype Q a = Q { unQ :: forall m. Quasi m => m a }
+-
 --- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
 --- should not need this function, as the splice brackets @$( ... )@
 --- are the usual way of running a 'Q' computation.
 ---
 --- This function is primarily used in GHC internals, and for debugging
 --- splices by running them in 'IO'.
 ---
 --- Note that many functions in 'Q', such as 'reify' and other compiler
 --- queries, are not supported when running 'Q' in 'IO'; these operations
 --- simply fail at runtime. Indeed, the only operations guaranteed to succeed
 --- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
 -runQ :: Quasi m => Q a -> m a
 -runQ (Q m) = m
 +-- | 'Q' is the base 'Monad' for TemplateHaskell splices,
 +-- similar to how 'IO' is the base 'Monad' for normal Haskell programs.
 +newtype Q a = Q { unQ :: MetaHandlers -> IO a }
  instance Monad Q where
 -  Q m >>= k  = Q (m >>= \x -> unQ (k x))
 +  Q m >>= k  = Q $ \h -> (m h >>= \x -> unQ (k x) h)
    (>>) = (*>)
  instance MonadFail Q where
 -  fail s     = report True s >> Q (fail "Q monad failure")
 +  fail s     = report True s >> Q (\h -> mFail h "Q monad failure")
  instance Functor Q where
 -  fmap f (Q x) = Q (fmap f x)
 +  fmap f (Q x) = Q $ \h -> fmap f (x h)
  instance Applicative Q where
 -  pure x = Q (pure x)
 -  Q f <*> Q x = Q (f <*> x)
 -  Q m *> Q n = Q (m *> n)
 +  pure x = Q $ \_ -> pure x
 +  Q f <*> Q x = Q $ \h -> (f h <*> x h)
 +  Q m *> Q n = Q $ \h -> (m h *> n h)
  -- | @since 2.17.0.0
  instance Semigroup a => Semigroup (Q a) where
@@ -319,7 +302,7 @@ class Monad m => Quote m where
    newName :: String -> m Name
  instance Quote Q where
 -  newName s = Q (qNewName s)
 +  newName s = Q $ \h -> mNewName h s
  -----------------------------------------------------
  --
@@ -517,35 +500,26 @@ joinCode = flip bindCode id
  -- | Report an error (True) or warning (False),
  -- but carry on; use 'fail' to stop.
  report  :: Bool -> String -> Q ()
 -report b s = Q (qReport b s)
 -{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+-
 --- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
 -reportError :: String -> Q ()
 -reportError = report True
+-
 --- | Report a warning to the user, and carry on.
 -reportWarning :: String -> Q ()
 -reportWarning = report False
 +report b s = Q $ \h -> mReport h b s
  -- | Recover from errors raised by 'reportError' or 'fail'.
  recover :: Q a -- ^ handler to invoke on failure
          -> Q a -- ^ computation to run
          -> Q a
 -recover (Q r) (Q m) = Q (qRecover r m)
 +recover rec main = Q $ \h -> mRecover h rec main
  -- We don't export lookupName; the Bool isn't a great API
  -- Instead we export lookupTypeName, lookupValueName
  lookupName :: Bool -> String -> Q (Maybe Name)
 -lookupName ns s = Q (qLookupName ns s)
 +lookupName ns s = Q $ \h -> mLookupName h ns s
  -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
  lookupTypeName :: String -> Q (Maybe Name)
 -lookupTypeName  s = Q (qLookupName True s)
 +lookupTypeName  s = Q $ \h -> mLookupName h True s
  -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
  lookupValueName :: String -> Q (Maybe Name)
 -lookupValueName s = Q (qLookupName False s)
 +lookupValueName s = Q $ \h -> mLookupName h False s
  {-
  Note [Name lookup]
@@ -620,7 +594,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName':
  and to get information about @D@-the-type, use 'lookupTypeName'.
  -}
  reify :: Name -> Q Info
 -reify v = Q (qReify v)
 +reify v = Q $ \h -> mReify h v
  {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
  example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
@@ -629,7 +603,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
  'Nothing', so you may assume @bar@ has 'defaultFixity'.
  -}
  reifyFixity :: Name -> Q (Maybe Fixity)
 -reifyFixity nm = Q (qReifyFixity nm)
 +reifyFixity nm = Q $ \h -> mReifyFixity h nm
  {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
  @reifyType 'not@   returns @Bool -> Bool@, and
@@ -637,7 +611,7 @@ reifyFixity nm = Q (qReifyFixity nm)
  This works even if there's no explicit signature and the type or kind is inferred.
  -}
  reifyType :: Name -> Q Type
 -reifyType nm = Q (qReifyType nm)
 +reifyType nm = Q $ \h -> mReifyType h nm
  {- | Template Haskell is capable of reifying information about types and
  terms defined in previous declaration groups. Top-level declaration splices break up
@@ -729,7 +703,7 @@ has some discussion around this.
  -}
  reifyInstances :: Name -> [Type] -> Q [InstanceDec]
 -reifyInstances cls tys = Q (qReifyInstances cls tys)
 +reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys
  {- | @reifyRoles nm@ returns the list of roles associated with the parameters
  (both visible and invisible) of
@@ -748,20 +722,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i
  the role of the invisible @k@ parameter. Kind parameters are always nominal.
  -}
  reifyRoles :: Name -> Q [Role]
 -reifyRoles nm = Q (qReifyRoles nm)
 +reifyRoles nm = Q $ \h -> mReifyRoles h nm
  -- | @reifyAnnotations target@ returns the list of annotations
  -- associated with @target@.  Only the annotations that are
  -- appropriately typed is returned.  So if you have @Int@ and @String@
  -- annotations for the same target, you have to call this function twice.
  reifyAnnotations :: Data a => AnnLookup -> Q [a]
 -reifyAnnotations an = Q (qReifyAnnotations an)
 +reifyAnnotations an = Q $ \h -> mReifyAnnotations h an
  -- | @reifyModule mod@ looks up information about module @mod@.  To
  -- look up the current module, call this function with the return
  -- value of 'Language.Haskell.TH.Lib.thisModule'.
  reifyModule :: Module -> Q ModuleInfo
 -reifyModule m = Q (qReifyModule m)
 +reifyModule m = Q $ \h -> mReifyModule h m
  -- | @reifyConStrictness nm@ looks up the strictness information for the fields
  -- of the constructor with the name @nm@. Note that the strictness information
@@ -776,7 +750,7 @@ reifyModule m = Q (qReifyModule m)
  -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
  -- @-XStrictData@ language extension was enabled.
  reifyConStrictness :: Name -> Q [DecidedStrictness]
 -reifyConStrictness n = Q (qReifyConStrictness n)
 +reifyConStrictness n = Q $ \h -> mReifyConStrictness h n
  -- | Is the list of instances returned by 'reifyInstances' nonempty?
  --
@@ -789,7 +763,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys
  -- | The location at which this computation is spliced.
  location :: Q Loc
 -location = Q qLocation
 +location = Q mLocation
  -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
  -- Take care: you are guaranteed the ordering of calls to 'runIO' within
@@ -799,7 +773,7 @@ location = Q qLocation
  -- necessarily flushed when the compiler finishes running, so you should
  -- flush them yourself.
  runIO :: IO a -> Q a
 -runIO m = Q (qRunIO m)
 +runIO m = Q $ \h -> mLiftIO h m
  -- | Get the package root for the current package which is being compiled.
  -- This can be set explicitly with the -package-root flag but is normally
@@ -811,7 +785,7 @@ runIO m = Q (qRunIO m)
  -- change directory when compiling files but instead set the -package-root flag
  -- appropriately.
  getPackageRoot :: Q FilePath
 -getPackageRoot = Q qGetPackageRoot
 +getPackageRoot = Q mGetPackageRoot
  -- | Record external directories that runIO is using (dependent upon).
  -- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +804,7 @@ getPackageRoot = Q qGetPackageRoot
  --   * The state of the directory is read at the interface generation time,
  --     not at the time of the function call.
  addDependentDirectory :: FilePath -> Q ()
 -addDependentDirectory dp = Q (qAddDependentDirectory dp)
 +addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp
  -- | Record external files that runIO is using (dependent upon).
  -- The compiler can then recognize that it should re-compile the Haskell file
@@ -844,17 +818,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp)
  --
  --   * The dependency is based on file content, not a modification time
  addDependentFile :: FilePath -> Q ()
 -addDependentFile fp = Q (qAddDependentFile fp)
 +addDependentFile fp = Q $ \h -> mAddDependentFile h fp
  -- | Obtain a temporary file path with the given suffix. The compiler will
  -- delete this file after compilation.
  addTempFile :: String -> Q FilePath
 -addTempFile suffix = Q (qAddTempFile suffix)
 +addTempFile suffix = Q $ \h -> mAddTempFile h suffix
  -- | Add additional top-level declarations. The added declarations will be type
  -- checked along with the current declaration group.
  addTopDecls :: [Dec] -> Q ()
 -addTopDecls ds = Q (qAddTopDecls ds)
 +addTopDecls ds = Q $ \h -> mAddTopDecls h ds
  -- | Same as 'addForeignSource', but expects to receive a path pointing to the
  -- foreign file instead of a 'String' of its contents. Consider using this in
@@ -863,7 +837,7 @@ addTopDecls ds = Q (qAddTopDecls ds)
  -- This is a good alternative to 'addForeignSource' when you are trying to
  -- directly link in an object file.
  addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
 -addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
 +addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp
  -- | Add a finalizer that will run in the Q monad after the current module has
  -- been type checked. This only makes sense when run within a top-level splice.
@@ -872,7 +846,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
  -- 'reify' is able to find the local definitions when executed inside the
  -- finalizer.
  addModFinalizer :: Q () -> Q ()
 -addModFinalizer act = Q (qAddModFinalizer (unQ act))
 +addModFinalizer act = Q $ \h -> mAddModFinalizer h act
  -- | Adds a core plugin to the compilation pipeline.
  --
@@ -882,7 +856,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act))
  -- to tell the compiler that we needed to compile first a plugin module in the
  -- current package.
  addCorePlugin :: String -> Q ()
 -addCorePlugin plugin = Q (qAddCorePlugin plugin)
 +addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin
  -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
  -- a type-indexed finite map. That is,
@@ -896,20 +870,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin)
  -- Note that the state is local to the Haskell module in which the Template
  -- Haskell expression is executed.
  getQ :: Typeable a => Q (Maybe a)
 -getQ = Q qGetQ
 +getQ = Q mGetQ
  -- | Replace the state in the 'Q' monad. Note that the state is local to the
  -- Haskell module in which the Template Haskell expression is executed.
  putQ :: Typeable a => a -> Q ()
 -putQ x = Q (qPutQ x)
 +putQ x = Q $ \h -> mPutQ h x
  -- | Determine whether the given language extension is enabled in the 'Q' monad.
  isExtEnabled :: Extension -> Q Bool
 -isExtEnabled ext = Q (qIsExtEnabled ext)
 +isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext
  -- | List all enabled language extensions.
  extsEnabled :: Q [Extension]
 -extsEnabled = Q qExtsEnabled
 +extsEnabled = Q mExtsEnabled
  -- | Add Haddock documentation to the specified location. This will overwrite
  -- any documentation at the location if it already exists. This will reify the
@@ -928,48 +902,18 @@ extsEnabled = Q qExtsEnabled
  -- Adding documentation to anything outside of the current module will cause an
  -- error.
  putDoc :: DocLoc -> String -> Q ()
 -putDoc t s = Q (qPutDoc t s)
 +putDoc t s = Q $ \h -> mPutDoc h t s
  -- | Retrieves the Haddock documentation at the specified location, if one
  -- exists.
  -- It can be used to read documentation on things defined outside of the current
  -- module, provided that those modules were compiled with the @-haddock@ flag.
  getDoc :: DocLoc -> Q (Maybe String)
 -getDoc n = Q (qGetDoc n)
 +getDoc n = Q $ \h -> mGetDoc h n
  instance MonadIO Q where
    liftIO = runIO
 -instance Quasi Q where
 -  qNewName            = newName
 -  qReport             = report
 -  qRecover            = recover
 -  qReify              = reify
 -  qReifyFixity        = reifyFixity
 -  qReifyType          = reifyType
 -  qReifyInstances     = reifyInstances
 -  qReifyRoles         = reifyRoles
 -  qReifyAnnotations   = reifyAnnotations
 -  qReifyModule        = reifyModule
 -  qReifyConStrictness = reifyConStrictness
 -  qLookupName         = lookupName
 -  qLocation           = location
 -  qGetPackageRoot     = getPackageRoot
 -  qAddDependentFile   = addDependentFile
 -  qAddDependentDirectory = addDependentDirectory
 -  qAddTempFile        = addTempFile
 -  qAddTopDecls        = addTopDecls
 -  qAddForeignFilePath = addForeignFilePath
 -  qAddModFinalizer    = addModFinalizer
 -  qAddCorePlugin      = addCorePlugin
 -  qGetQ               = getQ
 -  qPutQ               = putQ
 -  qIsExtEnabled       = isExtEnabled
 -  qExtsEnabled        = extsEnabled
 -  qPutDoc             = putDoc
 -  qGetDoc             = getDoc
+-
+-
  ----------------------------------------------------
  -- The following operations are used solely in GHC.HsToCore.Quote when
  -- desugaring brackets. They are not necessary for the user, who can use

libraries/ghci/GHCi/TH.hs

  {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
 -    TupleSections, RecordWildCards, InstanceSigs, CPP #-}
 +    TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-}
  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  -- |
@@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do
  instance MonadIO GHCiQ where
    liftIO m = GHCiQ $ \_ -> m
 -instance TH.Quasi GHCiQ where
 -  qNewName str = ghcCmd (NewName str)
 -  qReport isError msg = ghcCmd (Report isError msg)
+-
 -  -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
 -  qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
 -    s <- readIORef sRef
 -    remoteTHCall (qsPipe s) StartRecover
 -    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
 -    remoteTHCall (qsPipe s) (EndRecover (isLeft e))
 -    case e of
 -      Left GHCiQException{} -> h sRef
 -      Right r -> return r
 -  qLookupName isType occ = ghcCmd (LookupName isType occ)
 -  qReify name = ghcCmd (Reify name)
 -  qReifyFixity name = ghcCmd (ReifyFixity name)
 -  qReifyType name = ghcCmd (ReifyType name)
 -  qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
 -  qReifyRoles name = ghcCmd (ReifyRoles name)
+-
    -- To reify annotations, we send GHC the AnnLookup and also the
    -- TypeRep of the thing we're looking for, to avoid needing to
    -- serialize irrelevant annotations.
 -  qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
 -  qReifyAnnotations lookup =
 +reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
 +reifyAnnotations lookup =
      map (deserializeWithData . B.unpack) <$>
        ghcCmd (ReifyAnnotations lookup typerep)
      where typerep = typeOf (undefined :: a)
 -  qReifyModule m = ghcCmd (ReifyModule m)
 -  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
 -  qLocation = fromMaybe noLoc . qsLocation <$> getState
 -  qGetPackageRoot        = ghcCmd GetPackageRoot
 -  qAddDependentFile file = ghcCmd (AddDependentFile file)
 -  qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
 -  qAddTempFile suffix = ghcCmd (AddTempFile suffix)
 -  qAddTopDecls decls = ghcCmd (AddTopDecls decls)
 -  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
 -  qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
 +runQinGHCiQ :: TH.Q a -> GHCiQ a
 +runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef))
 +  where
 +    runInIO :: IORef QState -> GHCiQ a -> IO a
 +    runInIO sRef (GHCiQ m) = m sRef
++
 +metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers
 +metaHandlersGHCiQ runInIO = TH.MetaHandlers {
 +    mLiftIO = id
 +  , mFail = runInIO . fail
 +  , mNewName = \str -> runInIO $ ghcCmd (NewName str)
 +  , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg)
++
 +  -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
 +  , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do
 +      s <- readIORef sRef
 +      remoteTHCall (qsPipe s) StartRecover
 +      e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef
 +      remoteTHCall (qsPipe s) (EndRecover (isLeft e))
 +      case e of
 +        Left GHCiQException{} ->
 +          runGHCiQ (runQinGHCiQ h) sRef
 +        Right r -> return r
 +  , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ)
 +  , mReify = \name ->runInIO $ ghcCmd (Reify name)
 +  , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name)
 +  , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name)
 +  , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys)
 +  , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name)
++
 +  , mReifyAnnotations = runInIO . reifyAnnotations
 +  , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m)
 +  , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name)
 +  , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState
 +  , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot
 +  , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file)
 +  , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir)
 +  , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix)
 +  , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls)
 +  , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp)
 +  , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>=
                           ghcCmd . AddModFinalizer
 -  qAddCorePlugin str = ghcCmd (AddCorePlugin str)
 -  qGetQ = do
 +  , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str)
 +  , mGetQ = runInIO $ do
      s <- getState
      let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
          lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
      return $ lookup (qsMap s)
 -  qPutQ k = GHCiQ $ \sRef ->
 -    modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
 -  qIsExtEnabled x = ghcCmd (IsExtEnabled x)
 -  qExtsEnabled = ghcCmd ExtsEnabled
 -  qPutDoc l s = ghcCmd (PutDoc l s)
 -  qGetDoc l = ghcCmd (GetDoc l)
 +  , mPutQ = \k -> runInIO $ GHCiQ $ \sRef ->
 +      modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
 +  , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x)
 +  , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled
 +  , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s)
 +  , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l)
 +}
  -- | The implementation of the 'StartTH' message: create
  -- a new IORef QState, and return a RemoteRef to it.
@@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do
    qstateref <- localRef rstate
    qstate <- readIORef qstateref
    qstate' <- newIORef $ qstate { qsPipe = pipe }
 -  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
 +  _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate'
    return ()
  -- | The implementation of the 'RunTH' message
@@ -272,5 +284,5 @@ runTHQ
  runTHQ pipe rstate mb_loc ghciq = do
    qstateref <- localRef rstate
    modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
 -  r <- runGHCiQ (TH.runQ ghciq) qstateref
 +  r <- runGHCiQ (runQinGHCiQ ghciq) qstateref
    return $! LB.toStrict (runPut (put r))

libraries/template-haskell/Language/Haskell/TH/Syntax.hs

@@ -5,13 +5,17 @@
  {-# LANGUAGE TemplateHaskellQuotes #-}
  {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE UnboxedTuples #-}
 +-- Don't warn for using 'report' from ghc-internal
 +{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
  module Language.Haskell.TH.Syntax (
      Quote (..),
      Exp (..),
      Match (..),
      Clause (..),
 -    Q (..),
 +    Q,
 +    -- backwards compatibility
 +    Language.Haskell.TH.Syntax.unQ,
      Pat (..),
      Stmt (..),
      Con (..),
@@ -202,11 +206,14 @@ where
  import GHC.Boot.TH.Lift
  import GHC.Boot.TH.Syntax
 -import GHC.Boot.TH.Monad
 +import GHC.Boot.TH.Monad hiding (report)
 +import qualified GHC.Boot.TH.Monad as Internal
  import System.FilePath
  import Data.Data hiding (Fixity(..))
  import Data.List.NonEmpty (NonEmpty(..))
  import GHC.Lexeme ( startsVarSym, startsVarId )
 +import Control.Monad.IO.Class (MonadIO, liftIO)
 +import System.IO (hPutStrLn, stderr)
  -- This module completely re-exports 'GHC.Boot.TH.Syntax',
  -- and exports additionally functions that depend on @filepath@ or @System.IO@.
@@ -499,3 +506,172 @@ reassociate the tree as necessary.
  -- Subsumed by the more general 'SpecialiseEP' constructor.
  pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma
  pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases
++
 +unQ :: Q a -> (forall m. Quasi m => m a)
 +unQ m =  runQ m
++
 +-----------------------------------------------------
 +--
 +--              The Quasi class
 +--
 +-----------------------------------------------------
++
 +-- | The 'Quasi' typeclass used to provide an exhaustive list of the effects exposed by the 'Q' monad.
 +-- This invariant no longer holds, and it is encouraged to use 'Q' or 'Quote' instead.
 +class (MonadIO m, MonadFail m) => Quasi m where
 +  qRunQ :: Q a -> m a
 +  -- | Fresh names. See 'newName'.
 +  qNewName :: String -> m Name
 +  qNewName = qRunQ . newName
++
 +  ------- Error reporting and recovery -------
 +  -- | Report an error (True) or warning (False)
 +  -- ...but carry on; use 'fail' to stop. See 'report'.
 +  qReport  :: Bool -> String -> m ()
 +  qReport b s = qRunQ $ report b s
++
 +  -- | See 'recover'.
 +  qRecover :: m a -- ^ the error handler
 +           -> m a -- ^ action which may fail
 +           -> m a -- ^ Recover from the monadic 'fail'
++
 +  ------- Inspect the type-checker's environment -------
 +  -- | True <=> type namespace, False <=> value namespace. See 'lookupName'.
 +  qLookupName :: Bool -> String -> m (Maybe Name)
 +  qLookupName ns s = qRunQ $ lookupName ns s
 +  -- | See 'reify'.
 +  qReify          :: Name -> m Info
 +  qReify v = qRunQ $ reify v
 +  -- | See 'reifyFixity'.
 +  qReifyFixity    :: Name -> m (Maybe Fixity)
 +  qReifyFixity v = qRunQ $ reifyFixity v
 +  -- | See 'reifyType'.
 +  qReifyType      :: Name -> m Type
 +  qReifyType v = qRunQ $ reifyType v
 +  -- | Is (n tys) an instance? Returns list of matching instance Decs (with
 +  -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'.
 +  qReifyInstances :: Name -> [Type] -> m [Dec]
 +  qReifyInstances cls tys = qRunQ $ reifyInstances cls tys
 +  -- | See 'reifyRoles'.
 +  qReifyRoles         :: Name -> m [Role]
 +  qReifyRoles nm = qRunQ $ reifyRoles nm
 +  -- | See 'reifyAnnotations'.
 +  qReifyAnnotations   :: Data a => AnnLookup -> m [a]
 +  qReifyAnnotations an = qRunQ $ reifyAnnotations an
 +  -- | See 'reifyModule'.
 +  qReifyModule        :: Module -> m ModuleInfo
 +  qReifyModule m = qRunQ $ reifyModule m
 +  -- | See 'reifyConStrictness'.
 +  qReifyConStrictness :: Name -> m [DecidedStrictness]
 +  qReifyConStrictness nm = qRunQ $ reifyConStrictness nm
++
 +  -- | See 'location'.
 +  qLocation :: m Loc
 +  qLocation = qRunQ location
++
 +  -- | Input/output (dangerous). See 'runIO'.
 +  qRunIO :: IO a -> m a
 +  qRunIO = liftIO
 +  -- | See 'getPackageRoot'.
 +  qGetPackageRoot :: m FilePath
 +  qGetPackageRoot = qRunQ getPackageRoot
++
 +  -- | See 'addDependentFile'.
 +  qAddDependentFile :: FilePath -> m ()
 +  qAddDependentFile p = qRunQ $ addDependentFile p
++
 +  -- | See 'addDependentDirectory'.
 +  qAddDependentDirectory :: FilePath -> m ()
 +  qAddDependentDirectory p = qRunQ $ addDependentDirectory p
++
 +  -- | See 'addTempFile'.
 +  qAddTempFile :: String -> m FilePath
 +  qAddTempFile p = qRunQ $ addTempFile p
++
 +  -- | See 'addTopDecls'.
 +  qAddTopDecls :: [Dec] -> m ()
 +  qAddTopDecls decls = qRunQ $ addTopDecls decls
++
 +  -- | See 'addForeignFilePath'.
 +  qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
 +  qAddForeignFilePath lang fp = qRunQ $ addForeignFilePath lang fp
++
 +  -- | See 'addModFinalizer'.
 +  qAddModFinalizer :: Q () -> m ()
 +  qAddModFinalizer fin = qRunQ $ addModFinalizer fin
++
 +  -- | See 'addCorePlugin'.
 +  qAddCorePlugin :: String -> m ()
 +  qAddCorePlugin nm = qRunQ $ addCorePlugin nm
++
 +  -- | See 'getQ'.
 +  qGetQ :: Typeable a => m (Maybe a)
 +  qGetQ = qRunQ getQ
++
 +  -- | See 'putQ'.
 +  qPutQ :: Typeable a => a -> m ()
 +  qPutQ x = qRunQ $ putQ x
++
 +  -- | See 'isExtEnabled'.
 +  qIsExtEnabled :: Extension -> m Bool
 +  qIsExtEnabled ext = qRunQ $ isExtEnabled ext
 +  -- | See 'extsEnabled'.
 +  qExtsEnabled :: m [Extension]
 +  qExtsEnabled = qRunQ extsEnabled
++
 +  -- | See 'putDoc'.
 +  qPutDoc :: DocLoc -> String -> m ()
 +  qPutDoc l s = qRunQ $ putDoc l s
 +  -- | See 'getDoc'.
 +  qGetDoc :: DocLoc -> m (Maybe String)
 +  qGetDoc l = qRunQ $ getDoc l
++
 +-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
 +-- should not need this function, as the splice brackets @$( ... )@
 +-- are the usual way of running a 'Q' computation.
 +--
 +-- This function is primarily used in GHC internals, and for debugging
 +-- splices by running them in 'IO'.
 +--
 +-- Note that many functions in 'Q', such as 'reify' and other compiler
 +-- queries, are not supported when running 'Q' in 'IO'; these operations
 +-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
 +-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
 +runQ :: Quasi m => Q a -> m a
 +runQ = qRunQ
++
 +-----------------------------------------------------
 +--      The IO instance of Quasi
 +-----------------------------------------------------
++
 +--  | This instance is used only when running a Q
 +--  computation in the IO monad, usually just to
 +--  print the result.  There is no interesting
 +--  type environment, so reification isn't going to
 +--  work. Please use 'Quote' instead, which is much safer.
 +instance Quasi IO where
 +  qRunQ (Q m) = m metaHandlersIO
 +  qNewName = newNameIO
++
 +  qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
 +  qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
 +  qRecover _ _          = badIO "recover" -- Maybe we could fix this?
++
 +instance Quasi Q where
 +  qRunQ               = id
 +  qRecover            = recover
++
++
 +-- | Report an error (True) or warning (False),
 +-- but carry on; use 'fail' to stop.
 +report  :: Bool -> String -> Q ()
 +report = Internal.report
 +{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
++
 +-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
 +reportError :: String -> Q ()
 +reportError = report True
++
 +-- | Report a warning to the user, and carry on.
 +reportWarning :: String -> Q ()
 +reportWarning = report False

testsuite/tests/interface-stability/template-haskell-exports.stdout

@@ -354,7 +354,6 @@ module Language.Haskell.TH where
    type Pred = Type
    type PredQ :: *
    type PredQ = Q Pred
 -  type role Q nominal
    type Q :: * -> *
    newtype Q a = ...
    type Quote :: (* -> *) -> Constraint
@@ -655,7 +654,7 @@ module Language.Haskell.TH where
    roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec
    ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr
    runIO :: forall a. GHC.Internal.Types.IO a -> Q a
 -  runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a
 +  runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a
    safe :: Safety
    sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
@@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where
    data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
    type Pred :: *
    type Pred = Type
 -  type role Q nominal
    type Q :: * -> *
 -  newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a}
 +  newtype Q a = ...
    type Quasi :: (* -> *) -> Constraint
    class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where
 +    qRunQ :: forall a. Q a -> m a
      qNewName :: GHC.Internal.Base.String -> m Name
      qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m ()
      qRecover :: forall a. m a -> m a -> m a
@@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where
      qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
      qAddModFinalizer :: Q () -> m ()
      qAddCorePlugin :: GHC.Internal.Base.String -> m ()
 -    qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
 -    qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
 +    qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
 +    qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
      qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool
      qExtsEnabled :: m [Extension]
      qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
      qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
 -    {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
 +    {-# MINIMAL qRunQ, qRecover #-}
    type Quote :: (* -> *) -> Constraint
    class GHC.Internal.Base.Monad m => Quote m where
      newName :: GHC.Internal.Base.String -> m Name
@@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where
    falseName :: Name
    getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
    getPackageRoot :: Q GHC.Internal.IO.FilePath
 -  getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
 +  getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
    get_cons_names :: Con -> [Name]
    hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
    isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool
@@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where
    oneName :: Name
    pkgString :: PkgName -> GHC.Internal.Base.String
    putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
 -  putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
 +  putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
    recover :: forall a. Q a -> Q a -> Q a
    reify :: Name -> Q Info
    reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
@@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where
    trueName :: Name
    tupleDataName :: GHC.Internal.Types.Int -> Name
    tupleTypeName :: GHC.Internal.Types.Int -> Name
 +  unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a
    unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp
    unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp
    unboxedSumDataName :: SumAlt -> SumArity -> Name
@@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif
  instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’
  instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’
  instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’
 -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
 -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
  instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’
  instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’
  instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’
  instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’
  instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’
 +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’
 +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’