GitLab

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

Commits:

81baed9d
by Teo Camarasu at 2026-03-14T01:09:55+00:00
```
wip: Abstract Q
```
3fd2d50d
by Teo Camarasu at 2026-03-14T01:09:55+00:00
```
wip
```

4 changed files:

compiler/GHC/Data/IOEnv.hs
compiler/GHC/Tc/Gen/Splice.hs
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
libraries/ghci/GHCi/TH.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) = unliftIOEnv $ \runInIO -> liftIO $ act runInIO metaHandlersTcM
  runRemoteModFinalizers :: ThModFinalizers -> TcM ()
  runRemoteModFinalizers (ThModFinalizers finRefs) = do
@@ -1466,68 +1467,12 @@ 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 :: Bool -> [Char] -> TcM ()
 +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 +1500,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
@@ -1622,15 +1528,129 @@ 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
 +                      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) }) }
++
 +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.
 +          -- NB: extremely subtle!!! TODO: write up note
 +          -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env
 +    , mRecover = \recover main -> tryTcDiscardingErrs (runQuasi recover) (runQuasi 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 +1815,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 +1931,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 $ runQuasi $ TH.newName a
 +  Report b str -> wrapTHResult $ runQuasi $ TH.report b str
 +  LookupName b str -> wrapTHResult $ runQuasi $ TH.lookupName b str
 +  Reify n -> wrapTHResult $ runQuasi $ TH.reify n
 +  ReifyFixity n -> wrapTHResult $ runQuasi $ TH.reifyFixity n
 +  ReifyType n -> wrapTHResult $ runQuasi $ TH.reifyType n
 +  ReifyInstances n ts -> wrapTHResult $ runQuasi $ TH.reifyInstances n ts
 +  ReifyRoles n -> wrapTHResult $ runQuasi $ 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 $ runQuasi $ TH.reifyModule m
 +  ReifyConStrictness nm -> wrapTHResult $ runQuasi $ TH.reifyConStrictness nm
 +  GetPackageRoot -> wrapTHResult $ runQuasi $ TH.getPackageRoot
 +  AddDependentFile f -> wrapTHResult $ runQuasi $ TH.addDependentFile f
 +  AddDependentDirectory d -> wrapTHResult $ runQuasi $ TH.addDependentDirectory d
 +  AddTempFile s -> wrapTHResult $ runQuasi $ 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 $ runQuasi $ TH.addCorePlugin str
 +  AddTopDecls decs -> wrapTHResult $ runQuasi $ TH.addTopDecls decs
 +  AddForeignFilePath lang str -> wrapTHResult $ runQuasi $ TH.addForeignFilePath lang str
 +  IsExtEnabled ext -> wrapTHResult $ runQuasi $ TH.isExtEnabled ext
 +  ExtsEnabled -> wrapTHResult $ runQuasi $ TH.extsEnabled
 +  PutDoc l s -> wrapTHResult $ runQuasi $ TH.putDoc l s
 +  GetDoc l -> wrapTHResult $ runQuasi $ TH.getDoc 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 id metaHandlersIO
    qNewName = newNameIO
    qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
@@ -180,9 +182,124 @@ instance Quasi IO where
    qGetDoc _             = badIO "getDoc"
    qAddDependentDirectory _ = badIO "AddDependentDirectory"
 +metaHandlersIO :: MetaHandlers IO
 +metaHandlersIO  = MetaHandlers {
 +   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
 +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. Q a -- ^ the error handler
 +            -> Q 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 +330,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 :: forall m. (forall x. m x -> IO x) -> MetaHandlers m -> IO a }
  -- | \"Runs\" the 'Q' monad. Normal users of Template Haskell
  -- should not need this function, as the splice brackets @$( ... )@
@@ -227,22 +344,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 $ \r h -> (m r h >>= \x -> unQ (k x) r h)
    (>>) = (*>)
  instance MonadFail Q where
 -  fail s     = report True s >> Q (fail "Q monad failure")
 +  fail s     = report True s >> Q (\_ _ -> fail "Q monad failure")
  instance Functor Q where
 -  fmap f (Q x) = Q (fmap f x)
 +  fmap f (Q x) = Q $ \r h -> fmap f (x r 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 $ \r h -> (f r h <*> x r h)
 +  Q m *> Q n = Q $ \r h -> (m r h *> n r h)
  -- | @since 2.17.0.0
  instance Semigroup a => Semigroup (Q a) where
@@ -311,8 +428,17 @@ class Monad m => Quote m where
    -}
    newName :: String -> m Name
 +runHandler :: (forall m. MetaHandlers m -> m a) -> Q a
 +runHandler op = Q $ \r h -> r (op h)
++
 +runHandler1 :: (forall m. MetaHandlers m -> a -> m b) -> a -> Q b
 +runHandler1 op = \x -> Q $ \r h -> r (op h x)
++
 +runHandler2 :: (forall m. MetaHandlers m -> a -> b -> m c) -> a -> b -> Q c
 +runHandler2 op = \x y -> Q $ \r h -> r (op h x y)
++
  instance Quote Q where
 -  newName s = Q (qNewName s)
 +  newName = runHandler1 mNewName
  -----------------------------------------------------
  --
@@ -510,7 +636,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 = runHandler2 mReport 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 +651,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 rec main = Q $ \r h -> r $ 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 = runHandler2 mLookupName 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 = runHandler2 mLookupName 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 = runHandler2 mLookupName False s
  {-
  Note [Name lookup]
@@ -613,7 +739,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 = runHandler1 mReify 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 +748,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 = runHandler1 mReifyFixity nm
  {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
  @reifyType 'not@   returns @Bool -> Bool@, and
@@ -630,7 +756,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 = runHandler1 mReifyType 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 +848,7 @@ has some discussion around this.
  -}
  reifyInstances :: Name -> [Type] -> Q [InstanceDec]
 -reifyInstances cls tys = Q (qReifyInstances cls tys)
 +reifyInstances cls tys = runHandler2 mReifyInstances cls tys
  {- | @reifyRoles nm@ returns the list of roles associated with the parameters
  (both visible and invisible) of
@@ -741,20 +867,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 = runHandler1 mReifyRoles 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 = runHandler1 mReifyAnnotations 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 = runHandler1 mReifyModule 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 +895,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 = runHandler1 mReifyConStrictness n
  -- | Is the list of instances returned by 'reifyInstances' nonempty?
  --
@@ -782,7 +908,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys
  -- | The location at which this computation is spliced.
  location :: Q Loc
 -location = Q qLocation
 +location = runHandler 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 +918,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 $ \_ _ -> 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 +930,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 = runHandler 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 +949,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 = runHandler1 mAddDependentDirectory 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 +963,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 = runHandler1 mAddDependentFile 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 = runHandler1 mAddTempFile 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 = runHandler1 mAddTopDecls 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 +982,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 = runHandler2 mAddForeignFilePath 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 +991,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 = runHandler1 mAddModFinalizer act
  -- | Adds a core plugin to the compilation pipeline.
  --
@@ -875,7 +1001,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 = runHandler1 mAddCorePlugin plugin
  -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to
  -- a type-indexed finite map. That is,
@@ -889,20 +1015,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 = runHandler 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 = runHandler1 mPutQ x
  -- | Determine whether the given language extension is enabled in the 'Q' monad.
  isExtEnabled :: Extension -> Q Bool
 -isExtEnabled ext = Q (qIsExtEnabled ext)
 +isExtEnabled ext = runHandler1 mIsExtEnabled ext
  -- | List all enabled language extensions.
  extsEnabled :: Q [Extension]
 -extsEnabled = Q qExtsEnabled
 +extsEnabled = runHandler 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 +1047,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 = runHandler2 mPutDoc 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 = runHandler1 mGetDoc n
  instance MonadIO Q where
    liftIO = runIO
  instance Quasi Q where
 +  qRunQ               = id
    qNewName            = newName
    qReport             = report
    qRecover            = recover

libraries/ghci/GHCi/TH.hs

@@ -163,56 +163,67 @@ ghcCmd m = GHCiQ $ \s -> do
  instance MonadIO GHCiQ where
    liftIO m = GHCiQ $ \s -> fmap (,s) 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 $ \s -> mask $ \unmask -> do
 -    remoteTHCall (qsPipe s) StartRecover
 -    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
 -    remoteTHCall (qsPipe s) (EndRecover (isLeft e))
 -    case e of
 -      Left GHCiQException{} -> h s
 -      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 (\s -> mkRemoteRef fin >>= return . (, s)) >>=
 +-- TODO: !!!
 +-- This is wrong because it will discard any updates to the state.
 +-- What I should do instead is refactor GHCiQ first (!) to use an IORef for state, and then save/restore that.
 +runQinGHCiQ :: TH.Q a -> GHCiQ a
 +runQinGHCiQ (TH.Q m) = GHCiQ $ \s -> (,s) <$> m (runInIO s) metaHandlersGHCiQ
 +  where
 +    runInIO :: QState -> GHCiQ a -> IO a
 +    runInIO s (GHCiQ m) = fst <$> m s
++
 +metaHandlersGHCiQ = TH.MetaHandlers {
 +    mNewName = \str -> ghcCmd (NewName str)
 +  , mReport = \isError msg -> ghcCmd (Report isError msg)
++
 +  -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
 +  , mRecover = \h a -> GHCiQ $ \s -> mask $ \unmask -> do
 +      remoteTHCall (qsPipe s) StartRecover
 +      e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) s -- TODO: simplify
 +      remoteTHCall (qsPipe s) (EndRecover (isLeft e))
 +      case e of
 +        Left GHCiQException{} -> runGHCiQ (runQinGHCiQ h) s -- TODO: simplify
 +        Right r -> return r
 +  , mLookupName = \isType occ -> ghcCmd (LookupName isType occ)
 +  , mReify = \name -> ghcCmd (Reify name)
 +  , mReifyFixity = \name -> ghcCmd (ReifyFixity name)
 +  , mReifyType = \name -> ghcCmd (ReifyType name)
 +  , mReifyInstances = \name tys -> ghcCmd (ReifyInstances name tys)
 +  , mReifyRoles = \name -> ghcCmd (ReifyRoles name)
++
 +  , mReifyAnnotations = reifyAnnotations
 +  , mReifyModule = \m -> ghcCmd (ReifyModule m)
 +  , mReifyConStrictness = \name -> ghcCmd (ReifyConStrictness name)
 +  , mLocation = fromMaybe noLoc . qsLocation <$> getState
 +  , mGetPackageRoot = ghcCmd GetPackageRoot
 +  , mAddDependentFile = \file -> ghcCmd (AddDependentFile file)
 +  , mAddDependentDirectory = \dir -> ghcCmd (AddDependentDirectory dir)
 +  , mAddTempFile = \suffix -> ghcCmd (AddTempFile suffix)
 +  , mAddTopDecls = \decls -> ghcCmd (AddTopDecls decls)
 +  , mAddForeignFilePath = \lang fp -> ghcCmd (AddForeignFilePath lang fp)
 +  , mAddModFinalizer = \fin -> GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
                           ghcCmd . AddModFinalizer
 -  qAddCorePlugin str = ghcCmd (AddCorePlugin str)
 -  qGetQ = GHCiQ $ \s ->
 +  , mAddCorePlugin = \str -> ghcCmd (AddCorePlugin str)
 +  , mGetQ = GHCiQ $ \s ->
      let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
          lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
      in return (lookup (qsMap s), s)
 -  qPutQ k = GHCiQ $ \s ->
 +  , mPutQ = \k -> GHCiQ $ \s ->
      return ((), 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)
 +  , mIsExtEnabled = \x -> ghcCmd (IsExtEnabled x)
 +  , mExtsEnabled = ghcCmd ExtsEnabled
 +  , mPutDoc = \l s -> ghcCmd (PutDoc l s)
 +  , mGetDoc = \l -> ghcCmd (GetDoc l)
 +}
  -- | The implementation of the 'StartTH' message: create
  -- a new IORef QState, and return a RemoteRef to it.
@@ -231,7 +242,7 @@ runModFinalizerRefs pipe rstate qrefs = do
    qs <- mapM localRef qrefs
    qstateref <- localRef rstate
    qstate <- readIORef qstateref
 -  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
 +  _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate { qsPipe = pipe }
    return ()
  -- | The implementation of the 'RunTH' message
@@ -269,6 +280,6 @@ runTHQ pipe rstate mb_loc ghciq = do
    qstateref <- localRef rstate
    qstate <- readIORef qstateref
    let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
 -  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
 +  (r,new_state) <- runGHCiQ (runQinGHCiQ ghciq) st
    writeIORef qstateref new_state
    return $! LB.toStrict (runPut (put r))