Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC Commits: 6047c446 by Teo Camarasu at 2026-03-19T23:27:24+00:00 try without runInIo - - - - - 3 changed files: - compiler/GHC/Tc/Gen/Splice.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghci/GHCi/TH.hs Changes: ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1140,7 +1140,7 @@ convertAnnotationWrapper fhv = do -} runQuasi :: TH.Q a -> TcM a -runQuasi (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act runInIO metaHandlersTcM +runQuasi (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act (metaHandlersTcM runInIO) runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do @@ -1557,71 +1557,71 @@ location = do { m <- getModule , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } -metaHandlersTcM :: TH.MetaHandlers TcM -metaHandlersTcM = TH.MetaHandlers { - mFail = fail - , mNewName = \s -> do { u <- newUnique +metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers IO +metaHandlersTcM runInIO = TH.MetaHandlers { + mFail = \s -> runInIO $ fail s + , mNewName = \s -> runInIO $ 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 + , 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. - -- 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) + -- -- 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 -> runInIO $ tryTcDiscardingErrs (runQuasi recover) (runQuasi main) - , mGetPackageRoot = do + , mGetPackageRoot = runInIO $ do dflags <- getDynFlags return $ fromMaybe "." (workingDirectory dflags) - , mAddDependentFile = \fp -> do + , mAddDependentFile = \fp -> runInIO $ do ref <- fmap tcg_dependent_files getGblEnv dep_files <- readTcRef ref writeTcRef ref (fp:dep_files) - , mAddDependentDirectory = \dp -> do + , mAddDependentDirectory = \dp -> runInIO $ do ref <- fmap tcg_dependent_dirs getGblEnv dep_dirs <- readTcRef ref writeTcRef ref (dp:dep_dirs) - , mAddTempFile = \suffix -> do + , mAddTempFile = \suffix -> runInIO $ do dflags <- getDynFlags logger <- getLogger tmpfs <- hsc_tmpfs <$> getTopEnv liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix - , mAddTopDecls = addTopDecls + , mAddTopDecls = runInIO . addTopDecls - , mAddForeignFilePath = \lang fp -> do + , mAddForeignFilePath = \lang fp -> runInIO $ do var <- fmap tcg_th_foreign_files getGblEnv updTcRef var ((lang, fp) :) - , mAddModFinalizer = \fin -> do + , mAddModFinalizer = \fin -> runInIO $ do r <- liftIO $ mkRemoteRef fin fref <- liftIO $ mkForeignRef r (freeRemoteRef r) addModFinalizerRef fref - , mAddCorePlugin = \plugin -> do + , mAddCorePlugin = \plugin -> runInIO $ do hsc_env <- getTopEnv let fc = hsc_FC hsc_env let home_unit = hsc_home_unit hsc_env @@ -1636,20 +1636,20 @@ metaHandlersTcM = TH.MetaHandlers { th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv updTcRef th_coreplugins_var (plugin:) - , mGetQ = getQ + , mGetQ = runInIO getQ - , mPutQ = \x -> do + , 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 = xoptM + , mIsExtEnabled = runInIO . xoptM - , mExtsEnabled = + , mExtsEnabled = runInIO $ EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - , mPutDoc = putDoc + , mPutDoc = fmap runInIO . putDoc - , mGetDoc = getDoc + , mGetDoc = runInIO . getDoc } -- | Looks up documentation for a declaration in first the current module, ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -150,7 +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 + qRunQ (Q m) = m metaHandlersIO qNewName = newNameIO qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) @@ -332,7 +332,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. (forall x. m x -> IO x) -> MetaHandlers m -> IO 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 @$( ... )@ @@ -349,19 +349,19 @@ runQ :: Quasi m => Q a -> m a runQ = qRunQ instance Monad Q where - Q m >>= k = Q $ \r h -> (m r h >>= \x -> unQ (k x) r h) + Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h) (>>) = (*>) instance MonadFail Q where - fail s = report True s >> Q (\r h -> r $ mFail h "Q monad failure") + fail s = report True s >> Q (\h -> mFail h "Q monad failure") instance Functor Q where - fmap f (Q x) = Q $ \r h -> fmap f (x r h) + fmap f (Q x) = Q $ \h -> fmap f (x h) instance Applicative Q where - 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) + 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 @@ -431,13 +431,13 @@ 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) +runHandler op = Q $ \h -> (op h) runHandler1 :: (forall m. MetaHandlers m -> a -> m b) -> a -> Q b -runHandler1 op = \x -> Q $ \r h -> r (op h x) +runHandler1 op = \x -> Q $ \h -> (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) +runHandler2 op = \x y -> Q $ \h -> (op h x y) instance Quote Q where newName = runHandler1 mNewName @@ -653,7 +653,7 @@ reportWarning = report False recover :: Q a -- ^ handler to invoke on failure -> Q a -- ^ computation to run -> Q a -recover rec main = Q $ \r h -> r $ mRecover h rec main +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 @@ -920,7 +920,7 @@ location = runHandler mLocation -- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a -runIO m = Q $ \_ _ -> 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 ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric, - TupleSections, RecordWildCards, InstanceSigs, CPP #-} + TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -174,18 +174,19 @@ reifyAnnotations lookup = where typerep = typeOf (undefined :: a) runQinGHCiQ :: TH.Q a -> GHCiQ a -runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (runInIO sRef) metaHandlersGHCiQ +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 = TH.MetaHandlers { - mFail = fail - , mNewName = \str -> ghcCmd (NewName str) - , mReport = \isError msg -> ghcCmd (Report isError msg) +metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers IO +metaHandlersGHCiQ runInIO = TH.MetaHandlers { + 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 -> GHCiQ $ \sRef -> mask $ \unmask -> do + , 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 @@ -195,37 +196,37 @@ metaHandlersGHCiQ = TH.MetaHandlers { -- in case of error, restore the state to the start of the `recover` block. newIORef s >>= runGHCiQ (runQinGHCiQ h) 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) >>= + , 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 (\s -> mkRemoteRef fin) >>= ghcCmd . AddModFinalizer - , mAddCorePlugin = \str -> ghcCmd (AddCorePlugin str) - , mGetQ = 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) - , mPutQ = \k -> GHCiQ $ \sRef -> + , mPutQ = \k -> runInIO $ GHCiQ $ \sRef -> modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) - , mIsExtEnabled = \x -> ghcCmd (IsExtEnabled x) - , mExtsEnabled = ghcCmd ExtsEnabled - , mPutDoc = \l s -> ghcCmd (PutDoc l s) - , mGetDoc = \l -> ghcCmd (GetDoc l) + , 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6047c446732ba2243b69c39d4ade28bc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6047c446732ba2243b69c39d4ade28bc... You're receiving this email because of your account on gitlab.haskell.org.