GitLab

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

Commits:

67f9f5be
by Teo Camarasu at 2026-03-12T23:06:39+00:00
```
wip: Abstract Q
```

3 changed files:

compiler/GHC/Data/IOEnv.hs
compiler/GHC/Tc/Gen/Splice.hs
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs

Changes:

@@ -29,7 +29,7 @@ module GHC.Data.IOEnv (
          -- I/O operations
          IORef, newMutVar, readMutVar, writeMutVar, updMutVar,
 -        atomicUpdMutVar, atomicUpdMutVar'
 +        atomicUpdMutVar, atomicUpdMutVar', unliftIOEnv
    ) where
  import GHC.Prelude
@@ -258,3 +258,10 @@ 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)
++
 +unliftIOEnv :: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b
 +unliftIOEnv 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

@@ -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)
@@ -1139,7 +1140,7 @@ convertAnnotationWrapper fhv = do
  -}
  runQuasi :: TH.Q a -> TcM a
 -runQuasi act = TH.runQ act
 +runQuasi (TH.Q act) = runMetaHandlersInTcM metaHandlersTcM >>= liftIO . act
  runRemoteModFinalizers :: ThModFinalizers -> TcM ()
  runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1466,68 +1467,11 @@ 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]
 -  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
 -                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
 -                                                    (ppr l)
 -                        RealSrcSpan s _ -> return s
 -                 ; 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
 +report True msg  = seqList msg $ addErr        $ TcRnTHError $ ReportCustomQuasiError True  msg
 +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
++
 +addTopDecls :: [TH.Dec] -> TcM ()
 +addTopDecls thds = do
        exts <- fmap extensionFlags getDynFlags
        l <- getSrcSpanM
        th_origin <- getThSpliceOrigin
@@ -1555,52 +1499,12 @@ 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 doc_loc s = do
      th_doc_var <- tcg_th_docs <$> getGblEnv
      resolved_doc_loc <- resolve_loc doc_loc
      is_local <- checkLocalName resolved_doc_loc
@@ -1623,14 +1527,184 @@ instance TH.Quasi TcM where
        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.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
 +                      UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
 +                                                  (ppr l)
 +                      RealSrcSpan s _ -> return s
 +              ; 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) }) }
++
 +runMetaHandlersInTcM :: TH.MetaHandlers TcM -> TcM (TH.MetaHandlers IO)
 +runMetaHandlersInTcM mh = unliftIOEnv $ \unliftTcM -> do
 +  let
 +    unliftTcM2 :: (a -> b -> TcM c) -> a -> b -> IO c
 +    unliftTcM2 m x y = unliftTcM (m x y)
 +  pure $ TH.MetaHandlers {
 +    mNewName = unliftTcM . mNewName mh
++
 +    -- 'msg' is forced to ensure exceptions don't escape,
 +    -- see Note [Exceptions in TH]
 +    , mReport = unliftTcM2 $ mReport mh
++
 +    , mLocation = unliftTcM $ mLocation mh
++
 +    , mLookupName       = unliftTcM2 $ mLookupName mh
 +    , mReify            = unliftTcM . mReify mh
 +    , mReifyFixity      = unliftTcM . mReifyFixity mh
 +    , mReifyType        = unliftTcM . mReifyType mh
 +    , mReifyInstances   = unliftTcM2 $ mReifyInstances mh
 +    , mReifyRoles       = unliftTcM . mReifyRoles mh
 +    , mReifyAnnotations = unliftTcM . mReifyAnnotations mh
 +    , mReifyModule      = unliftTcM . mReifyModule mh
 +    , mReifyConStrictness = unliftTcM . mReifyConStrictness mh
++
 +          -- For qRecover, discard error messages if
 +          -- the recovery action is chosen.  Otherwise
 +          -- we'll only fail higher up.
 +    , mRecover = \recover main -> unliftTcM $ mRecover mh (liftIO recover) (liftIO main)
++
 +    , mGetPackageRoot = unliftTcM $ mGetPackageRoot mh
++
 +    , mAddDependentFile = unliftTcM . mAddDependentFile mh
++
 +    , mAddDependentDirectory = unliftTcM . mAddDependentDirectory mh
++
 +    , mAddTempFile = unliftTcM . mAddTempFile mh
++
 +    , mAddTopDecls = unliftTcM . mAddTopDecls mh
++
 +    , mAddForeignFilePath = unliftTcM2 $ mAddForeignFilePath mh
++
 +    , mAddModFinalizer = unliftTcM . mAddModFinalizer mh
++
 +    , mAddCorePlugin = unliftTcM . mAddCorePlugin mh
++
 +    , mGetQ = unliftTcM $ mGetQ mh
++
 +    , mPutQ = unliftTcM . mPutQ mh
++
 +    , mIsExtEnabled = unliftTcM . mIsExtEnabled mh
++
 +    , mExtsEnabled = unliftTcM $ mExtsEnabled mh
++
 +    , mPutDoc = unliftTcM2 $ mPutDoc mh
++
 +    , mGetDoc = unliftTcM . mGetDoc mh
 +  }
++
 +metaHandlersTcM :: TH.MetaHandlers TcM
 +metaHandlersTcM = TH.MetaHandlers {
 +    mNewName = \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]
 +    , mReport = report
++
 +    , mLocation = location
++
 +    , mLookupName       = lookupName
 +    , mReify            = reify
 +    , mReifyFixity      = \nm -> lookupThName nm >>= reifyFixity
 +    , mReifyType        = reifyTypeOfThing
 +    , mReifyInstances   = reifyInstances
 +    , mReifyRoles       = reifyRoles
 +    , mReifyAnnotations = reifyAnnotations
 +    , mReifyModule      = reifyModule
 +    , mReifyConStrictness = \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.
 +    , mRecover = \recover main -> tryTcDiscardingErrs recover main
++
 +    , mGetPackageRoot = do
 +        dflags <- getDynFlags
 +        return $ fromMaybe "." (workingDirectory dflags)
++
 +    , mAddDependentFile = \fp -> do
 +        ref <- fmap tcg_dependent_files getGblEnv
 +        dep_files <- readTcRef ref
 +        writeTcRef ref (fp:dep_files)
++
 +    , mAddDependentDirectory = \dp -> do
 +        ref <- fmap tcg_dependent_dirs getGblEnv
 +        dep_dirs <- readTcRef ref
 +        writeTcRef ref (dp:dep_dirs)
++
 +    , mAddTempFile = \suffix -> do
 +        dflags <- getDynFlags
 +        logger <- getLogger
 +        tmpfs  <- hsc_tmpfs <$> getTopEnv
 +        liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
++
 +    , mAddTopDecls = addTopDecls
++
 +    , mAddForeignFilePath = \lang fp -> do
 +        var <- fmap tcg_th_foreign_files getGblEnv
 +        updTcRef var ((lang, fp) :)
++
 +    , mAddModFinalizer = \fin -> do
 +        r <- liftIO $ mkRemoteRef fin
 +        fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
 +        addModFinalizerRef fref
++
 +    , mAddCorePlugin = \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:)
++
 +    , mGetQ = getQ
++
 +    , mPutQ = \x -> do
 +        th_state_var <- fmap tcg_th_state getGblEnv
 +        updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
++
 +    , mIsExtEnabled = xoptM
++
 +    , mExtsEnabled =
 +        EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
++
 +    , mPutDoc = putDoc
++
 +    , mGetDoc = 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)
@@ -1795,7 +1869,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 ->
@@ -1911,32 +1985,33 @@ 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
 -  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
 -  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
 +  -- TODO
 +  -- 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
 +  -- 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
 +  -- 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
    FailIfErrs -> wrapTHResult failIfErrsM
    _ -> panic ("handleTHMessage: unexpected message " ++ show msg)

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

@@ -59,6 +59,7 @@ import GHC.Internal.TH.Syntax
  -----------------------------------------------------
  class (MonadIO m, MonadFail m) => Quasi m where
 +  qRunQ :: Q a -> m a
    -- | Fresh names. See 'newName'.
    qNewName :: String -> m Name
@@ -149,6 +150,7 @@ class (MonadIO m, MonadFail m) => Quasi m where
  --  type environment, so reification isn't going to
  --  work.
  instance Quasi IO where
 +  qRunQ (Q m) = m (MetaHandlers {}) -- TODO: create a metahandlers instance which matches the quasi instance, ie, mostly badIO
    qNewName = newNameIO
    qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
@@ -183,6 +185,86 @@ instance Quasi IO where
  instance Quote IO where
    newName = newNameIO
 +data MetaHandlers m = MetaHandlers {
 +    -- | Fresh names. See 'newName'.
 +    mNewName :: String -> m Name
++
 +    ------- Error reporting and recovery -------
 +    -- | Report an error (True) or warning (False)
 +    -- ...but carry on; use 'fail' to stop. See 'report'.
 +    , mReport  :: Bool -> String -> m ()
++
 +    -- | See 'recover'.
 +    , mRecover :: forall a. 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'.
 +    , mLookupName :: Bool -> String -> m (Maybe Name)
 +    -- | See 'reify'.
 +    , mReify          :: Name -> m Info
 +    -- | See 'reifyFixity'.
 +    , mReifyFixity    :: Name -> m (Maybe Fixity)
 +    -- | See 'reifyType'.
 +    , mReifyType      :: 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'.
 +    , mReifyInstances :: Name -> [Type] -> m [Dec]
 +    -- | See 'reifyRoles'.
 +    , mReifyRoles         :: Name -> m [Role]
 +    -- | See 'reifyAnnotations'.
 +    , mReifyAnnotations   :: forall a. Data a => AnnLookup -> m [a]
 +    -- | See 'reifyModule'.
 +    , mReifyModule        :: Module -> m ModuleInfo
 +    -- | See 'reifyConStrictness'.
 +    , mReifyConStrictness :: Name -> m [DecidedStrictness]
++
 +    -- | See 'location'.
 +    , mLocation :: m Loc
++
 +    -- | See 'getPackageRoot'.
 +    , mGetPackageRoot :: m FilePath
++
 +    -- | See 'addDependentFile'.
 +    , mAddDependentFile :: FilePath -> m ()
++
 +    -- | See 'addDependentDirectory'.
 +    , mAddDependentDirectory :: FilePath -> m ()
++
 +    -- | See 'addTempFile'.
 +    , mAddTempFile :: String -> m FilePath
++
 +    -- | See 'addTopDecls'.
 +    , mAddTopDecls :: [Dec] -> m ()
++
 +    -- | See 'addForeignFilePath'.
 +    , mAddForeignFilePath :: ForeignSrcLang -> String -> m ()
++
 +    -- | See 'addModFinalizer'.
 +    , mAddModFinalizer :: Q () -> m ()
++
 +    -- | See 'addCorePlugin'.
 +    , mAddCorePlugin :: String -> m ()
++
 +    -- | See 'getQ'.
 +    , mGetQ :: forall a. Typeable a => m (Maybe a)
++
 +    -- | See 'putQ'.
 +    , mPutQ :: forall a. Typeable a => a -> m ()
++
 +    -- | See 'isExtEnabled'.
 +    , mIsExtEnabled :: Extension -> m Bool
 +    -- | See 'extsEnabled'.
 +    , mExtsEnabled :: m [Extension]
++
 +    -- | See 'putDoc'.
 +    , mPutDoc :: DocLoc -> String -> m ()
 +    -- | See 'getDoc'.
 +    , mGetDoc :: DocLoc -> m (Maybe String)
 +  }
++
++
  newNameIO :: String -> IO Name
  newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
                   ; pure (mkNameU s n) }
@@ -213,7 +295,7 @@ counter = unsafePerformIO (newIORef 0)
  -- 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 }
 +newtype Q a = Q { unQ :: MetaHandlers IO -> IO a }
  -- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
  -- should not need this function, as the splice brackets @$( ... )@
@@ -227,22 +309,22 @@ newtype Q a = Q { unQ :: forall m. Quasi m => m a }
  -- 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
 +runQ = qRunQ
  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 -> fail "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 $ \h -> (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
@@ -312,7 +394,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
  -----------------------------------------------------
  --
@@ -510,7 +592,7 @@ 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)
 +report b s = Q $ \h -> mReport h 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'.
@@ -525,20 +607,20 @@ reportWarning = report False
  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 (Q r) (Q m) = Q $ \h -> mRecover h (r h) (m h)
  -- 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]
@@ -613,7 +695,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
@@ -622,7 +704,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
@@ -630,7 +712,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
@@ -722,7 +804,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
@@ -741,20 +823,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
@@ -769,7 +851,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?
  --
@@ -782,7 +864,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
@@ -792,7 +874,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 -> 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
@@ -804,7 +886,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
@@ -823,7 +905,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
@@ -837,17 +919,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
@@ -856,7 +938,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.
@@ -865,7 +947,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.
  --
@@ -875,7 +957,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,
@@ -889,20 +971,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
@@ -921,19 +1003,20 @@ 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
 +  qRunQ               = id
    qNewName            = newName
    qReport             = report
    qRecover            = recover