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
=====================================
@@ -0,0 +1,9 @@
+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-Unl… 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
=====================================
@@ -1,5 +1,5 @@
{-# 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’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bb87c2cada6fd237b1c8bb0446c316…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bb87c2cada6fd237b1c8bb0446c316…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/davide/windows-dlls] WIP explicit exports
by David Eichmann (＠DavidEichmann) 25 Jun '26
by David Eichmann (＠DavidEichmann) 25 Jun '26
25 Jun '26
David Eichmann pushed to branch wip/davide/windows-dlls at Glasgow Haskell Compiler / GHC
Commits:
dc4a1a48 by David Eichmann at 2026-06-25T15:55:27+01:00
WIP explicit exports
- - - - -
3 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -269,6 +269,7 @@ data SectionType
| FiniArray -- .fini_array on ELF, .dtor on Windows
| CString
| IPE
+ | Directive -- .drectve on Windows
deriving (Show)
data SectionProtection
@@ -289,6 +290,7 @@ sectionProtection t = case t of
Data -> ReadWriteSection
UninitialisedData -> ReadWriteSection
IPE -> ReadWriteSection
+ Directive -> ReadOnlySection
{-
Note [Relocatable Read-Only Data]
@@ -548,3 +550,4 @@ pprSectionType s = doubleQuotes $ case s of
FiniArray -> text "finiarray"
CString -> text "cstring"
IPE -> text "ipe"
+ Directive -> text "drectve"
=====================================
compiler/GHC/CmmToAsm/Ppr.hs
=====================================
@@ -243,6 +243,7 @@ pprGNUSectionHeader config t suffix =
| OSMinGW32 <- platformOS platform
-> text ".rdata"
| otherwise -> text ".ipe"
+ Directive -> text ".drectve"
flags
-- See
-- https://github.com/llvm/llvm-project/blob/llvmorg-21.1.8/lld/COFF/Chunks.cp…
@@ -339,8 +340,9 @@ pprDarwinSectionHeader t = case t of
RelocatableReadOnlyData -> text ".const_data"
UninitialisedData -> text ".data"
InitArray -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"
- FiniArray -> panic "pprDarwinSectionHeader: fini not supported"
CString -> text ".section\t__TEXT,__cstring,cstring_literals"
IPE -> text ".const"
+ FiniArray -> panic "pprDarwinSectionHeader: fini not supported"
+ Directive -> panic "pprDarwinSectionHeader: drectve not supported"
{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-}
{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
=====================================
compiler/GHC/CmmToAsm/X86/Ppr.hs
=====================================
@@ -133,6 +133,9 @@ pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) =
-- ELF .size directive (size of the entry code function)
, pprSizeDecl platform proc_lbl
+
+ , -- Explicite export on windows (see Note [TODO])
+ pprExport config proc_lbl False
]
{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-}
{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
@@ -206,11 +209,17 @@ pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
, not $ platformOS platform == OSMinGW32 && ncgSplitSections config
= pprGloblDecl (ncgPlatform config) alias
$$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
+ $$ pprExport config lbl True
where
platform = ncgPlatform config
pprDatas config (align, (CmmStaticsRaw lbl dats))
- = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)
+ = vcat $
+ [ pprAlign platform align
+ , pprLabel platform lbl
+ ]
+ ++ (map (pprData config) dats)
+ ++ [pprExport config lbl True]
where
platform = ncgPlatform config
@@ -290,6 +299,27 @@ pprLabelType' platform lbl =
isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)
+-- See Note [TODO]
+pprExport :: IsDoc doc => NCGConfig -> CLabel -> Bool -> doc
+pprExport config lbl isCmmData =
+ if platformOS platform == OSMinGW32
+ && platformTablesNextToCode platform
+ && externallyVisibleCLabel lbl
+ then let
+ asData = isCmmData || isInfoTableLabel lbl
+ in
+ pprSectionAlign config (Section Directive lbl) $$
+ line (text ".ascii" <> doubleQuotes (
+ text " -export:"
+ <> pprAsmLabel platform lbl
+ <> if asData then text ",data" else empty
+ ))
+ else empty
+ where
+ platform = ncgPlatform config
+
+
+
pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprTypeDecl platform lbl
= if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc4a1a482c7727ee2693049c29c6c8f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc4a1a482c7727ee2693049c29c6c8f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json-flag] Remove deprecated flag `-ddump-json` (see #24113)
by Simon Hengel (＠sol) 25 Jun '26
by Simon Hengel (＠sol) 25 Jun '26
25 Jun '26
Simon Hengel pushed to branch wip/sol/remove-ddump-json-flag at Glasgow Haskell Compiler / GHC
Commits:
68cf630a by Simon Hengel at 2026-06-25T21:41:28+07:00
Remove deprecated flag `-ddump-json` (see #24113)
- - - - -
13 changed files:
- + changelog.d/remove-ddump-json-flag
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
Changes:
=====================================
changelog.d/remove-ddump-json-flag
=====================================
@@ -0,0 +1,4 @@
+section: compiler
+synopsis: Remove deprecated flag `-ddump-json`
+issues: #24113
+mrs: !16258
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -527,7 +527,6 @@ data DumpFlag
| Opt_D_dump_view_pattern_commoning
| Opt_D_verbose_core2core
| Opt_D_dump_debug
- | Opt_D_dump_json
| Opt_D_ppr_debug
| Opt_D_no_debug_output
| Opt_D_dump_faststrings
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1694,9 +1694,6 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_NoBignumRules))
, make_ord_flag defGhcFlag "ddump-debug"
(setDumpFlag Opt_D_dump_debug)
- , make_dep_flag defGhcFlag "ddump-json"
- (setDumpFlag Opt_D_dump_json)
- "Use `-fdiagnostics-as-json` instead"
, make_ord_flag defGhcFlag "dppr-debug"
(setDumpFlag Opt_D_ppr_debug)
, make_ord_flag defGhcFlag "ddebug-output"
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -549,15 +549,6 @@ instance ToJson Severity where
json SevWarning = JSString "Warning"
json SevError = JSString "Error"
-instance ToJson MessageClass where
- json MCOutput = JSString "MCOutput"
- json MCFatal = JSString "MCFatal"
- json MCInteractive = JSString "MCInteractive"
- json MCDump = JSString "MCDump"
- json MCInfo = JSString "MCInfo"
- json (MCDiagnostic sev reason code) =
- JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code)
-
instance ToJson DiagnosticCode where
json c = JSInt (fromIntegral (diagnosticCodeNumber c))
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -95,7 +95,6 @@ import GHC.Utils.Panic
import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
-import GHC.Data.FastString
import System.Directory
import System.FilePath ( takeDirectory, (</>) )
@@ -360,7 +359,6 @@ makeThreadSafe logger = do
$ pushTraceHook trc
$ logger
--- See Note [JSON Error Messages]
defaultLogJsonAction :: LogJsonAction
defaultLogJsonAction logflags msg_class jsdoc =
case msg_class of
@@ -377,33 +375,6 @@ defaultLogJsonAction logflags msg_class jsdoc =
putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
msg = renderJSON jsdoc
--- See Note [JSON Error Messages]
--- this is to be removed
-jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction
-jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message
-jsonLogActionWithHandle out logflags msg_class srcSpan msg
- =
- defaultLogActionHPutStrDoc logflags True out
- (withPprStyle PprCode (doc $$ text ""))
- where
- str = renderWithContext (log_default_user_context logflags) msg
- doc = renderJSON $
- JSObject [ ( "span", spanToDumpJSON srcSpan )
- , ( "doc" , JSString str )
- , ( "messageClass", json msg_class )
- ]
- spanToDumpJSON :: SrcSpan -> JsonDoc
- spanToDumpJSON s = case s of
- (RealSrcSpan rss _) -> JSObject [ ("file", json file)
- , ("startLine", json $ srcSpanStartLine rss)
- , ("startCol", json $ srcSpanStartCol rss)
- , ("endLine", json $ srcSpanEndLine rss)
- , ("endCol", json $ srcSpanEndCol rss)
- ]
- where file = unpackFS $ srcSpanFile rss
- GeneratedSrcSpan{} -> JSNull
- UnhelpfulSpan{} -> JSNull
-
-- | The default 'LogAction' prints to 'stdout' and 'stderr'.
--
-- To replicate the default log action behaviour with different @out@ and @err@
@@ -415,8 +386,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr
-- Allows clients to replicate the log message formatting of GHC with custom handles.
defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction
defaultLogActionWithHandles out err logflags msg_class srcSpan msg
- | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg
- | otherwise = case msg_class of
+ = case msg_class of
MCOutput -> printOut msg
MCDump -> printOut (msg $$ blankLine)
MCInteractive -> putStrSDoc msg
@@ -442,10 +412,6 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For
-- that reason we can not decorate the message in `defaultLogActionWithHandles`.
--
--- See also Note [JSON Error Messages]:
---
--- `jsonLogAction` should be removed along with -ddump-json
---
-- Also note that (1) is the reason why some parts of the compiler produce
-- diagnostics that don't respect `-fdiagnostics-as-json`.
--
@@ -493,28 +459,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
-- calls to this log-action can output all on the same line
= printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
---
--- Note [JSON Error Messages]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- When the user requests the compiler output to be dumped as json
--- we used to collect them all in an IORef and then print them at the end.
--- This doesn't work very well with GHCi. (See #14078) So instead we now
--- use the simpler method of just outputting a JSON document inplace to
--- stdout.
---
--- Before the compiler calls log_action, it has already turned the `ErrMsg`
--- into a formatted message. This means that we lose some possible
--- information to provide to the user but refactoring log_action is quite
--- invasive as it is called in many places. So, for now I left it alone
--- and we can refine its behaviour as users request different output.
---
--- The recent work here replaces the purpose of flag -ddump-json with
--- -fdiagnostics-as-json. For temporary backwards compatibility while
--- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
--- it should be removed along with -ddump-json. Similarly, the guard in
--- `defaultLogAction` should be removed. This cleanup is tracked in #24113.
-
-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -55,13 +55,6 @@ Dumping out compiler intermediate structures
``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the
output of one way with the output of another.
-.. ghc-flag:: -ddump-json
- :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead
- :type: dynamic
-
- This flag was previously used to generated JSON formatted GHC diagnostics,
- but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`.
-
.. ghc-flag:: -dshow-passes
:shortdesc: Print out each pass name as it happens
:type: dynamic
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -508,8 +508,6 @@ interactiveUI config baseDFlags srcs maybe_exprs = do
installInteractiveHomeUnits baseDFlags
- -- Update the LogAction. Ensure we don't override the user's log action lest
- -- we break -ddump-json (#14078)
lastErrLocationsRef <- liftIO $ newIORef []
pushLogHookM (ghciLogAction lastErrLocationsRef)
=====================================
testsuite/tests/driver/T16167.stderr
=====================================
@@ -1 +1,2 @@
+{"version":"1.2","ghcVersion":"ghc-9.15.20250819","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"rendered":"T16167.hs:1:8: error: [GHC-58481] parse error on input \u2018f\u2019\n","message":["parse error on input \u2018f\u2019"],"hints":[]}
*** Exception: ExitFailure 1
=====================================
testsuite/tests/driver/T16167.stdout deleted
=====================================
@@ -1,2 +0,0 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"}
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -271,12 +271,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef'])
test('T12955', normal, makefile_test, [])
test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
-test('json_dump', normal, compile_fail, ['-ddump-json'])
test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json'])
test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial'])
-test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
+test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version'])
test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
- ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])
+ ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs'])
test('T13604', [], makefile_test, [])
test('T13604a',
[ js_broken(22261) # require HPC support
=====================================
testsuite/tests/driver/json2.stderr
=====================================
@@ -1,2 +1,4 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"}
+TYPE SIGNATURES
+ foo :: forall a. a -> a
+Dependent modules: []
+Dependent packages: [(normal, base-4.21.0.0)]
=====================================
testsuite/tests/driver/json_dump.hs deleted
=====================================
@@ -1,6 +0,0 @@
-module Foo where
-
-import Data.List
-
-id1 :: a -> a
-id1 = 5
=====================================
testsuite/tests/driver/json_dump.stderr deleted
=====================================
@@ -1,2 +0,0 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68cf630a26104e13d074fb356448545…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68cf630a26104e13d074fb356448545…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json-flag] Remove deprecated flag `-ddump-json` (fixes #24113)
by Simon Hengel (＠sol) 25 Jun '26
by Simon Hengel (＠sol) 25 Jun '26
25 Jun '26
Simon Hengel pushed to branch wip/sol/remove-ddump-json-flag at Glasgow Haskell Compiler / GHC
Commits:
0830e955 by Simon Hengel at 2026-06-25T21:24:08+07:00
Remove deprecated flag `-ddump-json` (fixes #24113)
- - - - -
13 changed files:
- + changelog.d/remove-ddump-json-flag
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
Changes:
=====================================
changelog.d/remove-ddump-json-flag
=====================================
@@ -0,0 +1,4 @@
+section: compiler
+synopsis: Remove deprecated flag `-ddump-json`
+issues: #24113
+mrs: !16258
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -527,7 +527,6 @@ data DumpFlag
| Opt_D_dump_view_pattern_commoning
| Opt_D_verbose_core2core
| Opt_D_dump_debug
- | Opt_D_dump_json
| Opt_D_ppr_debug
| Opt_D_no_debug_output
| Opt_D_dump_faststrings
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1694,9 +1694,6 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_NoBignumRules))
, make_ord_flag defGhcFlag "ddump-debug"
(setDumpFlag Opt_D_dump_debug)
- , make_dep_flag defGhcFlag "ddump-json"
- (setDumpFlag Opt_D_dump_json)
- "Use `-fdiagnostics-as-json` instead"
, make_ord_flag defGhcFlag "dppr-debug"
(setDumpFlag Opt_D_ppr_debug)
, make_ord_flag defGhcFlag "ddebug-output"
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -549,15 +549,6 @@ instance ToJson Severity where
json SevWarning = JSString "Warning"
json SevError = JSString "Error"
-instance ToJson MessageClass where
- json MCOutput = JSString "MCOutput"
- json MCFatal = JSString "MCFatal"
- json MCInteractive = JSString "MCInteractive"
- json MCDump = JSString "MCDump"
- json MCInfo = JSString "MCInfo"
- json (MCDiagnostic sev reason code) =
- JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code)
-
instance ToJson DiagnosticCode where
json c = JSInt (fromIntegral (diagnosticCodeNumber c))
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -95,7 +95,6 @@ import GHC.Utils.Panic
import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
-import GHC.Data.FastString
import System.Directory
import System.FilePath ( takeDirectory, (</>) )
@@ -360,7 +359,6 @@ makeThreadSafe logger = do
$ pushTraceHook trc
$ logger
--- See Note [JSON Error Messages]
defaultLogJsonAction :: LogJsonAction
defaultLogJsonAction logflags msg_class jsdoc =
case msg_class of
@@ -377,33 +375,6 @@ defaultLogJsonAction logflags msg_class jsdoc =
putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
msg = renderJSON jsdoc
--- See Note [JSON Error Messages]
--- this is to be removed
-jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction
-jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message
-jsonLogActionWithHandle out logflags msg_class srcSpan msg
- =
- defaultLogActionHPutStrDoc logflags True out
- (withPprStyle PprCode (doc $$ text ""))
- where
- str = renderWithContext (log_default_user_context logflags) msg
- doc = renderJSON $
- JSObject [ ( "span", spanToDumpJSON srcSpan )
- , ( "doc" , JSString str )
- , ( "messageClass", json msg_class )
- ]
- spanToDumpJSON :: SrcSpan -> JsonDoc
- spanToDumpJSON s = case s of
- (RealSrcSpan rss _) -> JSObject [ ("file", json file)
- , ("startLine", json $ srcSpanStartLine rss)
- , ("startCol", json $ srcSpanStartCol rss)
- , ("endLine", json $ srcSpanEndLine rss)
- , ("endCol", json $ srcSpanEndCol rss)
- ]
- where file = unpackFS $ srcSpanFile rss
- GeneratedSrcSpan{} -> JSNull
- UnhelpfulSpan{} -> JSNull
-
-- | The default 'LogAction' prints to 'stdout' and 'stderr'.
--
-- To replicate the default log action behaviour with different @out@ and @err@
@@ -415,8 +386,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr
-- Allows clients to replicate the log message formatting of GHC with custom handles.
defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction
defaultLogActionWithHandles out err logflags msg_class srcSpan msg
- | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg
- | otherwise = case msg_class of
+ = case msg_class of
MCOutput -> printOut msg
MCDump -> printOut (msg $$ blankLine)
MCInteractive -> putStrSDoc msg
@@ -442,10 +412,6 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For
-- that reason we can not decorate the message in `defaultLogActionWithHandles`.
--
--- See also Note [JSON Error Messages]:
---
--- `jsonLogAction` should be removed along with -ddump-json
---
-- Also note that (1) is the reason why some parts of the compiler produce
-- diagnostics that don't respect `-fdiagnostics-as-json`.
--
@@ -493,28 +459,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
-- calls to this log-action can output all on the same line
= printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
---
--- Note [JSON Error Messages]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- When the user requests the compiler output to be dumped as json
--- we used to collect them all in an IORef and then print them at the end.
--- This doesn't work very well with GHCi. (See #14078) So instead we now
--- use the simpler method of just outputting a JSON document inplace to
--- stdout.
---
--- Before the compiler calls log_action, it has already turned the `ErrMsg`
--- into a formatted message. This means that we lose some possible
--- information to provide to the user but refactoring log_action is quite
--- invasive as it is called in many places. So, for now I left it alone
--- and we can refine its behaviour as users request different output.
---
--- The recent work here replaces the purpose of flag -ddump-json with
--- -fdiagnostics-as-json. For temporary backwards compatibility while
--- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
--- it should be removed along with -ddump-json. Similarly, the guard in
--- `defaultLogAction` should be removed. This cleanup is tracked in #24113.
-
-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -55,13 +55,6 @@ Dumping out compiler intermediate structures
``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the
output of one way with the output of another.
-.. ghc-flag:: -ddump-json
- :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead
- :type: dynamic
-
- This flag was previously used to generated JSON formatted GHC diagnostics,
- but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`.
-
.. ghc-flag:: -dshow-passes
:shortdesc: Print out each pass name as it happens
:type: dynamic
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -508,8 +508,6 @@ interactiveUI config baseDFlags srcs maybe_exprs = do
installInteractiveHomeUnits baseDFlags
- -- Update the LogAction. Ensure we don't override the user's log action lest
- -- we break -ddump-json (#14078)
lastErrLocationsRef <- liftIO $ newIORef []
pushLogHookM (ghciLogAction lastErrLocationsRef)
=====================================
testsuite/tests/driver/T16167.stderr
=====================================
@@ -1 +1,2 @@
+{"version":"1.2","ghcVersion":"ghc-9.15.20250819","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"rendered":"T16167.hs:1:8: error: [GHC-58481] parse error on input \u2018f\u2019\n","message":["parse error on input \u2018f\u2019"],"hints":[]}
*** Exception: ExitFailure 1
=====================================
testsuite/tests/driver/T16167.stdout deleted
=====================================
@@ -1,2 +0,0 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"}
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -271,12 +271,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef'])
test('T12955', normal, makefile_test, [])
test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
-test('json_dump', normal, compile_fail, ['-ddump-json'])
test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json'])
test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial'])
-test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
+test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version'])
test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
- ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])
+ ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs'])
test('T13604', [], makefile_test, [])
test('T13604a',
[ js_broken(22261) # require HPC support
=====================================
testsuite/tests/driver/json2.stderr
=====================================
@@ -1,2 +1,4 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"}
+TYPE SIGNATURES
+ foo :: forall a. a -> a
+Dependent modules: []
+Dependent packages: [(normal, base-4.21.0.0)]
=====================================
testsuite/tests/driver/json_dump.hs deleted
=====================================
@@ -1,6 +0,0 @@
-module Foo where
-
-import Data.List
-
-id1 :: a -> a
-id1 = 5
=====================================
testsuite/tests/driver/json_dump.stderr deleted
=====================================
@@ -1,2 +0,0 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0830e95599aceece69f8fadd8f0c880…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0830e95599aceece69f8fadd8f0c880…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/arm-ffi] Expand CCallConv test
by Andreas Klebinger (＠AndreasK) 25 Jun '26
by Andreas Klebinger (＠AndreasK) 25 Jun '26
25 Jun '26
Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC
Commits:
a9bd4d95 by Andreas Klebinger at 2026-06-25T16:19:57+02:00
Expand CCallConv test
On some platforms (e.g. arm64) we have invariants about zeroing the high bits of
returned values we want to catch.
- - - - -
3 changed files:
- testsuite/tests/codeGen/should_run/CCallConv.hs
- testsuite/tests/codeGen/should_run/CCallConv.stdout
- testsuite/tests/codeGen/should_run/CCallConv_c.c
Changes:
=====================================
testsuite/tests/codeGen/should_run/CCallConv.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ExtendedLiterals #-}
-- | This test ensures that sub-word signed and unsigned parameters are correctly
-- handed over to C functions. I.e. it asserts the calling-convention.
@@ -16,6 +17,7 @@ import Data.Word
import GHC.Exts
import GHC.Int
import System.IO
+import GHC.Stack
foreign import ccall "fun8"
fun8 ::
@@ -59,6 +61,31 @@ foreign import ccall "fun32"
Int32# -> -- s1
Int64# -- result
+foreign import ccall "shrink32"
+ shrink32 ::
+ Int64# -> -- a0
+ Int32# -- result
+
+foreign import ccall "shrink16"
+ shrink16 ::
+ Int64# -> -- a0
+ Int16# -- result
+
+foreign import ccall "shrink8"
+ shrink8 ::
+ Int64# -> -- a0
+ Int8# -- result
+
+foreign import ccall "shrink32_16"
+ shrink32_16 ::
+ Int32# -> -- a0
+ Int16# -- result
+
+foreign import ccall "shrink32_8"
+ shrink32_8 ::
+ Int32# -> -- a0
+ Int8# -- result
+
foreign import ccall "funFloat"
funFloat ::
Float# -> -- a0
@@ -115,6 +142,16 @@ main = do
hFlush stdout
assertEqual expected_res32 (I64# res32)
+ -- Shrinking/zeroing of subword sizes
+ do
+ assertTrue# (shrink32 -1#Int64 `eqInt32#` -1#Int32)
+ assertTrue# (shrink16 -1#Int64 `eqInt16#` -1#Int16)
+ assertTrue# (shrink8 -1#Int64 `eqInt8#` -1#Int8)
+
+ assertTrue# (shrink32_16 -1#Int32 `eqInt16#` -1#Int16)
+ assertTrue# (shrink32_8 -1#Int32 `eqInt8#` -1#Int8)
+
+
let resFloat :: Float = F# (funFloat 1.0# 1.1# 1.2# 1.3# 1.4# 1.5# 1.6# 1.7# 1.8# 1.9#)
print $ "funFloat result:" ++ show resFloat
hFlush stdout
@@ -130,3 +167,10 @@ assertEqual a b =
if a == b
then pure ()
else error $ show a ++ " =/= " ++ show b
+
+assertTrue# :: HasCallStack => Int# -> IO ()
+assertTrue# x =
+ case (I# x) of
+ 1 -> pure ()
+ 0 -> error $ "assertTrue# failed"
+
=====================================
testsuite/tests/codeGen/should_run/CCallConv.stdout
=====================================
@@ -34,6 +34,16 @@ a7: 0xffffffff -1
s0: 0xffffffff 4294967295
s1: 0xffffffff -1
"fun32 result:8589934582"
+shrink32:
+a0: 0xffffffffffffffff -1
+shrink16:
+a0: 0xffffffffffffffff -1
+shrink8:
+a0: 0xffffffffffffffff -1
+shrink32_16:
+a0: 0xffffffff 4294967295
+shrink32_8:
+a0: 0xffffffff 4294967295
funFloat:
a0: 1.000000
a1: 1.100000
=====================================
testsuite/tests/codeGen/should_run/CCallConv_c.c
=====================================
@@ -62,6 +62,51 @@ int64_t fun32(int32_t a0, uint32_t a1, int32_t a2, int32_t a3, int32_t a4,
s1;
}
+int32_t shrink32(int64_t a0) {
+ printf("shrink32:\n");
+ printf("a0: %#llx %lld\n", a0, a0);
+
+ fflush(stdout);
+
+ return a0;
+}
+
+int16_t shrink16(int64_t a0) {
+ printf("shrink16:\n");
+ printf("a0: %#llx %lld\n", a0, a0);
+
+ fflush(stdout);
+
+ return a0;
+}
+
+int8_t shrink8(int64_t a0) {
+ printf("shrink8:\n");
+ printf("a0: %#llx %lld\n", a0, a0);
+
+ fflush(stdout);
+
+ return a0;
+}
+
+int16_t shrink32_16(int32_t a0) {
+ printf("shrink32_16:\n");
+ printf("a0: %#llx %lld\n", a0, a0);
+
+ fflush(stdout);
+
+ return a0;
+}
+
+int8_t shrink32_8(int32_t a0) {
+ printf("shrink32_8:\n");
+ printf("a0: %#llx %lld\n", a0, a0);
+
+ fflush(stdout);
+
+ return a0;
+}
+
float funFloat(float a0, float a1, float a2, float a3, float a4, float a5,
float a6, float a7, float s0, float s1) {
printf("funFloat:\n");
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9bd4d9549c4a4eec4115445af1eea8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9bd4d9549c4a4eec4115445af1eea8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/9.12.5-rc3-fixes] Desugar a `case` scrutinee only once (#27383, #20251)
by Magnus (＠MangoIV) 25 Jun '26
by Magnus (＠MangoIV) 25 Jun '26
25 Jun '26
Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC
Commits:
3c837d7f by Sebastian Graf at 2026-06-25T15:57:57+02:00
Desugar a `case` scrutinee only once (#27383, #20251)
In `dsExpr` for `HsCase` we desugared the scrutinee /twice/: once to
build the Core `case` itself, and again inside `matchWrapper`, which
re-desugared the source scrutinee (via `addHsScrutTmCs`) purely to
record long-distance information for the pattern-match checker.
For a single `case` that is merely wasteful. But for nested cases it
is catastrophic. Consider
case (case (case e of ... ) of ... ) of ...
Desugaring the outer scrutinee desugars the middle `case` twice, each
of which desugars the inner `case` twice, and so on. The work doubles
at every level, so desugaring takes O(2^n) time in the nesting depth.
That is the blowup reported in #27383; it is also what makes the
machine-generated program in #20251 take an age to compile.
The fix is simple. `matchWrapper` is handed the scrutinee anyway, so
we give it the Core expression we have /already/ desugared, and record
the long-distance term constraint with `addCoreScrutTmCs` instead of
re-desugaring from source. This is just what `matchSinglePatVar`
already does for single-pattern matches.
So:
* `matchWrapper` now takes `Maybe [CoreExpr]` rather than
`Maybe [LHsExpr GhcTc]`.
* The `HsCase` equation of `dsExpr` passes the already-desugared
`core_discrim`; the arrow desugarer passes its match variables.
* `addHsScrutTmCs` had no other use, so it is gone.
Desugaring is now linear in the nesting depth. (The coverage checker
still runs `simpleOptExpr` over each scrutinee, which leaves the total
at O(n^2); that is ample.) The long-distance information itself is
unchanged: the checker sees precisely the Core that backs the
generated code.
Test: deSugar/should_compile/T27383
(cherry picked from commit 67d41299be96798702377e6e2b826f9c8e070821)
- - - - -
8 changed files:
- + changelog.d/fix-exponential-case-desugar-27383
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Pmc.hs
- + testsuite/tests/deSugar/should_compile/T27383.hs
- testsuite/tests/deSugar/should_compile/all.T
Changes:
=====================================
changelog.d/fix-exponential-case-desugar-27383
=====================================
@@ -0,0 +1,6 @@
+section: compiler
+synopsis: Fix exponential-time desugaring of nested ``case`` expressions.
+ The scrutinee is no longer desugared a second time when recording
+ long-distance information for the pattern-match checker.
+issues: #27383 #20251
+mrs: !16203
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -554,7 +554,7 @@ dsCmd ids local_vars stack_ty res_ty
in_ty = envStackType env_ids stack_ty'
discrims = map nlHsVar arg_ids
(discrim_vars, matching_code)
- <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match'
+ <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just (map Var arg_ids)) match'
core_body <- flip (bind_vars discrim_vars) matching_code <$>
traverse dsLExpr discrims
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -451,7 +451,7 @@ dsExpr (HsFunArr x _ _ _) = dataConCantHappen x
dsExpr (HsCase ctxt discrim matches)
= do { core_discrim <- dsLExpr discrim
- ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches
+ ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [core_discrim]) matches
; return (bindNonRec discrim_var core_discrim matching_code) }
-- Pepe: The binds are in scope in the body but NOT in the binding group
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -764,7 +764,7 @@ Call @match@ with all of this information!
matchWrapper
:: HsMatchContextRn -- ^ For shadowing warning messages
- -> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s)
+ -> Maybe [CoreExpr] -- ^ Already-desugared scrutinee(s)
-- see Note [matchWrapper scrutinees]
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
-> DsM ([Id], CoreExpr) -- ^ Results (usually passed to 'match')
@@ -820,7 +820,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- pmc for pattern synonyms
-- See Note [Long-distance information] in GHC.HsToCore.Pmc
- then addHsScrutTmCs (concat scrs) new_vars $
+ then addCoreScrutTmCs (concat scrs) new_vars $
pmcMatches origin (DsMatchContext ctxt locn) new_vars matches
-- When we're not doing PM checks on the match group,
=====================================
compiler/GHC/HsToCore/Match.hs-boot
=====================================
@@ -16,7 +16,7 @@ match :: [Id]
matchWrapper
:: HsMatchContextRn
- -> Maybe [LHsExpr GhcTc]
+ -> Maybe [CoreExpr]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.HsToCore.Pmc (
isMatchContextPmChecked, isMatchContextPmChecked_SinglePat,
-- See Note [Long-distance information]
- addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas,
+ addTyCs, addCoreScrutTmCs, getLdiNablas,
getNFirstUncovered
) where
@@ -63,7 +63,6 @@ import GHC.Utils.Panic
import GHC.Types.Var (EvVar, Var (..))
import GHC.Types.Id.Info
import GHC.Tc.Utils.TcType (evVarPred)
-import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
import GHC.HsToCore.Monad
import GHC.Data.Bag
import GHC.Data.OrdList
@@ -542,12 +541,6 @@ addCoreScrutTmCs (scr:scrs) (x:xs) k =
addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))
addCoreScrutTmCs _ _ _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ"
--- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.
-addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
-addHsScrutTmCs scrs vars k = do
- scr_es <- traverse dsLExpr scrs
- addCoreScrutTmCs scr_es vars k
-
{- Note [Long-distance information]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
@@ -564,15 +557,18 @@ and the nested case pattern match to see that the inner pattern match is
exhaustive: @c@ can't be @R@ anymore because it was matched in the first clause
of @f@.
-To achieve similar reasoning in the coverage checker, we keep track of the set
-of values that can reach a particular program point (often loosely referred to
-as "Covered set") in 'GHC.HsToCore.Monad.dsl_nablas'.
-We fill that set with Covered Nablas returned by the exported checking
-functions, which the call sites put into place with
-'GHC.HsToCore.Monad.updPmNablas'.
-Call sites also extend this set with facts from type-constraint dictionaries,
-case scrutinees, etc. with the exported functions 'addTyCs', 'addCoreScrutTmCs'
-and 'addHsScrutTmCs'.
+To achieve similar reasoning in the coverage checker:
+
+* We keep track of the set of values that can reach a particular program point
+ (often loosely refer red to as "Covered set") in 'GHC.HsToCore.Monad.dsl_nablas
+ :: LdiNablas'.
+
+* We fill that set with Covered Nablas returned by the exported checking functions,
+ which the call sites put into place with 'GHC.HsToCore.Monad.updPmNablas'.
+
+* Call sites also extend this set with facts from type-constraint dictionaries,
+ case scrutinees, etc. with the exported functions 'addTyCs' and
+ 'addCoreScrutTmCs'.
Note [Recovering from unsatisfiable pattern-matching constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/deSugar/should_compile/T27383.hs
=====================================
@@ -0,0 +1,9 @@
+-- Regression test for #27383 (and #20251): deeply nested cases whose
+-- scrutinees are themselves cases must desugar in polynomial (not
+-- exponential) time. With the bug the scrutinee is desugared twice at
+-- every level, so compiler allocation (tracked by this performance test)
+-- grows as O(2^n) in the nesting depth.
+module T27383 where
+
+zero :: Int
+zero = (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case (case 0 of x500 -> x500) of x499 -> x499) of x498 -> x498) of x497 -> x497) of x496 -> x496) of x495 -> x495) of x494 -> x494) of x493 -> x493) of x492 -> x492) of x491 -> x491) of x490 -> x490) of x489 -> x489) of x488 -> x488) of x487 -> x487) of x486 -> x486) of x485 -> x485) of x484 -> x484) of x483 -> x483) of x482 -> x482) of x481 -> x481) of x480 -> x480) of x479 -> x479) of x478 -> x478) of x477 -> x477) of x476 -> x476) of x475 -> x475) of x474 -> x474) of x473 -> x473) of x472 -> x472) of x471 -> x471) of x470 -> x470) of x469 -> x469) of x468 -> x468) of x467 -> x467) of x466 -> x466) of x465 -> x465) of x464 -> x464) of x463 -> x463) of x462 -> x462) of x461 -> x461) of x460 -> x460) of x459 -> x459) of x458 -> x458) of x457 -> x457) of x456 -> x456) of x455 -> x455) of x454 -> x454) of x453 -> x453) of x452 -> x452) of x451 -> x451) of x450 -> x450) of x449 -> x449) of x448 -> x448) of x447 -> x447) of x446 -> x446) of x445 -> x445) of x444 -> x444) of x443 -> x443) of x442 -> x442) of x441 -> x441) of x440 -> x440) of x439 -> x439) of x438 -> x438) of x437 -> x437) of x436 -> x436) of x435 -> x435) of x434 -> x434) of x433 -> x433) of x432 -> x432) of x431 -> x431) of x430 -> x430) of x429 -> x429) of x428 -> x428) of x427 -> x427) of x426 -> x426) of x425 -> x425) of x424 -> x424) of x423 -> x423) of x422 -> x422) of x421 -> x421) of x420 -> x420) of x419 -> x419) of x418 -> x418) of x417 -> x417) of x416 -> x416) of x415 -> x415) of x414 -> x414) of x413 -> x413) of x412 -> x412) of x411 -> x411) of x410 -> x410) of x409 -> x409) of x408 -> x408) of x407 -> x407) of x406 -> x406) of x405 -> x405) of x404 -> x404) of x403 -> x403) of x402 -> x402) of x401 -> x401) of x400 -> x400) of x399 -> x399) of x398 -> x398) of x397 -> x397) of x396 -> x396) of x395 -> x395) of x394 -> x394) of x393 -> x393) of x392 -> x392) of x391 -> x391) of x390 -> x390) of x389 -> x389) of x388 -> x388) of x387 -> x387) of x386 -> x386) of x385 -> x385) of x384 -> x384) of x383 -> x383) of x382 -> x382) of x381 -> x381) of x380 -> x380) of x379 -> x379) of x378 -> x378) of x377 -> x377) of x376 -> x376) of x375 -> x375) of x374 -> x374) of x373 -> x373) of x372 -> x372) of x371 -> x371) of x370 -> x370) of x369 -> x369) of x368 -> x368) of x367 -> x367) of x366 -> x366) of x365 -> x365) of x364 -> x364) of x363 -> x363) of x362 -> x362) of x361 -> x361) of x360 -> x360) of x359 -> x359) of x358 -> x358) of x357 -> x357) of x356 -> x356) of x355 -> x355) of x354 -> x354) of x353 -> x353) of x352 -> x352) of x351 -> x351) of x350 -> x350) of x349 -> x349) of x348 -> x348) of x347 -> x347) of x346 -> x346) of x345 -> x345) of x344 -> x344) of x343 -> x343) of x342 -> x342) of x341 -> x341) of x340 -> x340) of x339 -> x339) of x338 -> x338) of x337 -> x337) of x336 -> x336) of x335 -> x335) of x334 -> x334) of x333 -> x333) of x332 -> x332) of x331 -> x331) of x330 -> x330) of x329 -> x329) of x328 -> x328) of x327 -> x327) of x326 -> x326) of x325 -> x325) of x324 -> x324) of x323 -> x323) of x322 -> x322) of x321 -> x321) of x320 -> x320) of x319 -> x319) of x318 -> x318) of x317 -> x317) of x316 -> x316) of x315 -> x315) of x314 -> x314) of x313 -> x313) of x312 -> x312) of x311 -> x311) of x310 -> x310) of x309 -> x309) of x308 -> x308) of x307 -> x307) of x306 -> x306) of x305 -> x305) of x304 -> x304) of x303 -> x303) of x302 -> x302) of x301 -> x301) of x300 -> x300) of x299 -> x299) of x298 -> x298) of x297 -> x297) of x296 -> x296) of x295 -> x295) of x294 -> x294) of x293 -> x293) of x292 -> x292) of x291 -> x291) of x290 -> x290) of x289 -> x289) of x288 -> x288) of x287 -> x287) of x286 -> x286) of x285 -> x285) of x284 -> x284) of x283 -> x283) of x282 -> x282) of x281 -> x281) of x280 -> x280) of x279 -> x279) of x278 -> x278) of x277 -> x277) of x276 -> x276) of x275 -> x275) of x274 -> x274) of x273 -> x273) of x272 -> x272) of x271 -> x271) of x270 -> x270) of x269 -> x269) of x268 -> x268) of x267 -> x267) of x266 -> x266) of x265 -> x265) of x264 -> x264) of x263 -> x263) of x262 -> x262) of x261 -> x261) of x260 -> x260) of x259 -> x259) of x258 -> x258) of x257 -> x257) of x256 -> x256) of x255 -> x255) of x254 -> x254) of x253 -> x253) of x252 -> x252) of x251 -> x251) of x250 -> x250) of x249 -> x249) of x248 -> x248) of x247 -> x247) of x246 -> x246) of x245 -> x245) of x244 -> x244) of x243 -> x243) of x242 -> x242) of x241 -> x241) of x240 -> x240) of x239 -> x239) of x238 -> x238) of x237 -> x237) of x236 -> x236) of x235 -> x235) of x234 -> x234) of x233 -> x233) of x232 -> x232) of x231 -> x231) of x230 -> x230) of x229 -> x229) of x228 -> x228) of x227 -> x227) of x226 -> x226) of x225 -> x225) of x224 -> x224) of x223 -> x223) of x222 -> x222) of x221 -> x221) of x220 -> x220) of x219 -> x219) of x218 -> x218) of x217 -> x217) of x216 -> x216) of x215 -> x215) of x214 -> x214) of x213 -> x213) of x212 -> x212) of x211 -> x211) of x210 -> x210) of x209 -> x209) of x208 -> x208) of x207 -> x207) of x206 -> x206) of x205 -> x205) of x204 -> x204) of x203 -> x203) of x202 -> x202) of x201 -> x201) of x200 -> x200) of x199 -> x199) of x198 -> x198) of x197 -> x197) of x196 -> x196) of x195 -> x195) of x194 -> x194) of x193 -> x193) of x192 -> x192) of x191 -> x191) of x190 -> x190) of x189 -> x189) of x188 -> x188) of x187 -> x187) of x186 -> x186) of x185 -> x185) of x184 -> x184) of x183 -> x183) of x182 -> x182) of x181 -> x181) of x180 -> x180) of x179 -> x179) of x178 -> x178) of x177 -> x177) of x176 -> x176) of x175 -> x175) of x174 -> x174) of x173 -> x173) of x172 -> x172) of x171 -> x171) of x170 -> x170) of x169 -> x169) of x168 -> x168) of x167 -> x167) of x166 -> x166) of x165 -> x165) of x164 -> x164) of x163 -> x163) of x162 -> x162) of x161 -> x161) of x160 -> x160) of x159 -> x159) of x158 -> x158) of x157 -> x157) of x156 -> x156) of x155 -> x155) of x154 -> x154) of x153 -> x153) of x152 -> x152) of x151 -> x151) of x150 -> x150) of x149 -> x149) of x148 -> x148) of x147 -> x147) of x146 -> x146) of x145 -> x145) of x144 -> x144) of x143 -> x143) of x142 -> x142) of x141 -> x141) of x140 -> x140) of x139 -> x139) of x138 -> x138) of x137 -> x137) of x136 -> x136) of x135 -> x135) of x134 -> x134) of x133 -> x133) of x132 -> x132) of x131 -> x131) of x130 -> x130) of x129 -> x129) of x128 -> x128) of x127 -> x127) of x126 -> x126) of x125 -> x125) of x124 -> x124) of x123 -> x123) of x122 -> x122) of x121 -> x121) of x120 -> x120) of x119 -> x119) of x118 -> x118) of x117 -> x117) of x116 -> x116) of x115 -> x115) of x114 -> x114) of x113 -> x113) of x112 -> x112) of x111 -> x111) of x110 -> x110) of x109 -> x109) of x108 -> x108) of x107 -> x107) of x106 -> x106) of x105 -> x105) of x104 -> x104) of x103 -> x103) of x102 -> x102) of x101 -> x101) of x100 -> x100) of x99 -> x99) of x98 -> x98) of x97 -> x97) of x96 -> x96) of x95 -> x95) of x94 -> x94) of x93 -> x93) of x92 -> x92) of x91 -> x91) of x90 -> x90) of x89 -> x89) of x88 -> x88) of x87 -> x87) of x86 -> x86) of x85 -> x85) of x84 -> x84) of x83 -> x83) of x82 -> x82) of x81 -> x81) of x80 -> x80) of x79 -> x79) of x78 -> x78) of x77 -> x77) of x76 -> x76) of x75 -> x75) of x74 -> x74) of x73 -> x73) of x72 -> x72) of x71 -> x71) of x70 -> x70) of x69 -> x69) of x68 -> x68) of x67 -> x67) of x66 -> x66) of x65 -> x65) of x64 -> x64) of x63 -> x63) of x62 -> x62) of x61 -> x61) of x60 -> x60) of x59 -> x59) of x58 -> x58) of x57 -> x57) of x56 -> x56) of x55 -> x55) of x54 -> x54) of x53 -> x53) of x52 -> x52) of x51 -> x51) of x50 -> x50) of x49 -> x49) of x48 -> x48) of x47 -> x47) of x46 -> x46) of x45 -> x45) of x44 -> x44) of x43 -> x43) of x42 -> x42) of x41 -> x41) of x40 -> x40) of x39 -> x39) of x38 -> x38) of x37 -> x37) of x36 -> x36) of x35 -> x35) of x34 -> x34) of x33 -> x33) of x32 -> x32) of x31 -> x31) of x30 -> x30) of x29 -> x29) of x28 -> x28) of x27 -> x27) of x26 -> x26) of x25 -> x25) of x24 -> x24) of x23 -> x23) of x22 -> x22) of x21 -> x21) of x20 -> x20) of x19 -> x19) of x18 -> x18) of x17 -> x17) of x16 -> x16) of x15 -> x15) of x14 -> x14) of x13 -> x13) of x12 -> x12) of x11 -> x11) of x10 -> x10) of x9 -> x9) of x8 -> x8) of x7 -> x7) of x6 -> x6) of x5 -> x5) of x4 -> x4) of x3 -> x3) of x2 -> x2) of x1 -> x1)
=====================================
testsuite/tests/deSugar/should_compile/all.T
=====================================
@@ -115,3 +115,7 @@ test('T19883', normal, compile, [''])
test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
test('T23550', normal, compile, [''])
test('T24489', normal, compile, ['-O'])
+test('T27383',
+ [collect_compiler_stats('bytes allocated', 10)],
+ compile,
+ ['-Wincomplete-patterns'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c837d7f4a55e7b7779c58b305ac89a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c837d7f4a55e7b7779c58b305ac89a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json-flag] Remove deprecated flag `-ddump-json` (fixes #24113)
by Simon Hengel (＠sol) 25 Jun '26
by Simon Hengel (＠sol) 25 Jun '26
25 Jun '26
Simon Hengel pushed to branch wip/sol/remove-ddump-json-flag at Glasgow Haskell Compiler / GHC
Commits:
9356dbad by Simon Hengel at 2026-06-25T20:25:36+07:00
Remove deprecated flag `-ddump-json` (fixes #24113)
- - - - -
13 changed files:
- + changelog.d/remove-ddump-json-flag
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
Changes:
=====================================
changelog.d/remove-ddump-json-flag
=====================================
@@ -0,0 +1,4 @@
+section: compiler
+synopsis: Remove deprecated flag `-ddump-json`
+issues: #24113
+mrs: !16258
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -527,7 +527,6 @@ data DumpFlag
| Opt_D_dump_view_pattern_commoning
| Opt_D_verbose_core2core
| Opt_D_dump_debug
- | Opt_D_dump_json
| Opt_D_ppr_debug
| Opt_D_no_debug_output
| Opt_D_dump_faststrings
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1694,9 +1694,6 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_NoBignumRules))
, make_ord_flag defGhcFlag "ddump-debug"
(setDumpFlag Opt_D_dump_debug)
- , make_dep_flag defGhcFlag "ddump-json"
- (setDumpFlag Opt_D_dump_json)
- "Use `-fdiagnostics-as-json` instead"
, make_ord_flag defGhcFlag "dppr-debug"
(setDumpFlag Opt_D_ppr_debug)
, make_ord_flag defGhcFlag "ddebug-output"
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -549,15 +549,6 @@ instance ToJson Severity where
json SevWarning = JSString "Warning"
json SevError = JSString "Error"
-instance ToJson MessageClass where
- json MCOutput = JSString "MCOutput"
- json MCFatal = JSString "MCFatal"
- json MCInteractive = JSString "MCInteractive"
- json MCDump = JSString "MCDump"
- json MCInfo = JSString "MCInfo"
- json (MCDiagnostic sev reason code) =
- JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code)
-
instance ToJson DiagnosticCode where
json c = JSInt (fromIntegral (diagnosticCodeNumber c))
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -95,7 +95,6 @@ import GHC.Utils.Panic
import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
-import GHC.Data.FastString
import System.Directory
import System.FilePath ( takeDirectory, (</>) )
@@ -360,7 +359,6 @@ makeThreadSafe logger = do
$ pushTraceHook trc
$ logger
--- See Note [JSON Error Messages]
defaultLogJsonAction :: LogJsonAction
defaultLogJsonAction logflags msg_class jsdoc =
case msg_class of
@@ -377,33 +375,6 @@ defaultLogJsonAction logflags msg_class jsdoc =
putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
msg = renderJSON jsdoc
--- See Note [JSON Error Messages]
--- this is to be removed
-jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction
-jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message
-jsonLogActionWithHandle out logflags msg_class srcSpan msg
- =
- defaultLogActionHPutStrDoc logflags True out
- (withPprStyle PprCode (doc $$ text ""))
- where
- str = renderWithContext (log_default_user_context logflags) msg
- doc = renderJSON $
- JSObject [ ( "span", spanToDumpJSON srcSpan )
- , ( "doc" , JSString str )
- , ( "messageClass", json msg_class )
- ]
- spanToDumpJSON :: SrcSpan -> JsonDoc
- spanToDumpJSON s = case s of
- (RealSrcSpan rss _) -> JSObject [ ("file", json file)
- , ("startLine", json $ srcSpanStartLine rss)
- , ("startCol", json $ srcSpanStartCol rss)
- , ("endLine", json $ srcSpanEndLine rss)
- , ("endCol", json $ srcSpanEndCol rss)
- ]
- where file = unpackFS $ srcSpanFile rss
- GeneratedSrcSpan{} -> JSNull
- UnhelpfulSpan{} -> JSNull
-
-- | The default 'LogAction' prints to 'stdout' and 'stderr'.
--
-- To replicate the default log action behaviour with different @out@ and @err@
@@ -415,8 +386,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr
-- Allows clients to replicate the log message formatting of GHC with custom handles.
defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction
defaultLogActionWithHandles out err logflags msg_class srcSpan msg
- | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg
- | otherwise = case msg_class of
+ = case msg_class of
MCOutput -> printOut msg
MCDump -> printOut (msg $$ blankLine)
MCInteractive -> putStrSDoc msg
@@ -493,28 +463,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
-- calls to this log-action can output all on the same line
= printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
---
--- Note [JSON Error Messages]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- When the user requests the compiler output to be dumped as json
--- we used to collect them all in an IORef and then print them at the end.
--- This doesn't work very well with GHCi. (See #14078) So instead we now
--- use the simpler method of just outputting a JSON document inplace to
--- stdout.
---
--- Before the compiler calls log_action, it has already turned the `ErrMsg`
--- into a formatted message. This means that we lose some possible
--- information to provide to the user but refactoring log_action is quite
--- invasive as it is called in many places. So, for now I left it alone
--- and we can refine its behaviour as users request different output.
---
--- The recent work here replaces the purpose of flag -ddump-json with
--- -fdiagnostics-as-json. For temporary backwards compatibility while
--- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
--- it should be removed along with -ddump-json. Similarly, the guard in
--- `defaultLogAction` should be removed. This cleanup is tracked in #24113.
-
-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -55,13 +55,6 @@ Dumping out compiler intermediate structures
``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the
output of one way with the output of another.
-.. ghc-flag:: -ddump-json
- :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead
- :type: dynamic
-
- This flag was previously used to generated JSON formatted GHC diagnostics,
- but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`.
-
.. ghc-flag:: -dshow-passes
:shortdesc: Print out each pass name as it happens
:type: dynamic
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -508,8 +508,6 @@ interactiveUI config baseDFlags srcs maybe_exprs = do
installInteractiveHomeUnits baseDFlags
- -- Update the LogAction. Ensure we don't override the user's log action lest
- -- we break -ddump-json (#14078)
lastErrLocationsRef <- liftIO $ newIORef []
pushLogHookM (ghciLogAction lastErrLocationsRef)
=====================================
testsuite/tests/driver/T16167.stderr
=====================================
@@ -1 +1,2 @@
+{"version":"1.2","ghcVersion":"ghc-9.15.20250819","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"rendered":"T16167.hs:1:8: error: [GHC-58481] parse error on input \u2018f\u2019\n","message":["parse error on input \u2018f\u2019"],"hints":[]}
*** Exception: ExitFailure 1
=====================================
testsuite/tests/driver/T16167.stdout deleted
=====================================
@@ -1,2 +0,0 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"}
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -271,12 +271,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef'])
test('T12955', normal, makefile_test, [])
test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
-test('json_dump', normal, compile_fail, ['-ddump-json'])
test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json'])
test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches -Wx-partial'])
-test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
+test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version'])
test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
- ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])
+ ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs'])
test('T13604', [], makefile_test, [])
test('T13604a',
[ js_broken(22261) # require HPC support
=====================================
testsuite/tests/driver/json2.stderr
=====================================
@@ -1,2 +1,4 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"}
+TYPE SIGNATURES
+ foo :: forall a. a -> a
+Dependent modules: []
+Dependent packages: [(normal, base-4.21.0.0)]
=====================================
testsuite/tests/driver/json_dump.hs deleted
=====================================
@@ -1,6 +0,0 @@
-module Foo where
-
-import Data.List
-
-id1 :: a -> a
-id1 = 5
=====================================
testsuite/tests/driver/json_dump.stderr deleted
=====================================
@@ -1,2 +0,0 @@
-{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
-{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9356dbadfa613ad2df1904b05376f5f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9356dbadfa613ad2df1904b05376f5f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
25 Jun '26
Simon Hengel pushed new branch wip/sol/remove-ddump-json-flag at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sol/remove-ddump-json-flag
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: perf: Share Module in Iface Symbol Table
by Marge Bot (＠marge-bot) 25 Jun '26
by Marge Bot (＠marge-bot) 25 Jun '26
25 Jun '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2f1fc149 by Rodrigo Mesquita at 2026-06-25T08:57:45-04:00
perf: Share Module in Iface Symbol Table
This commit modifies the structure of the serialized `SymbolTable Name`
to then re-use and share the `Module` (both on disk and in memory) across
all `Name`s from the same module.
The new structure looks like:
<total name count>
$modules.size
for (mod, names) in $modules:
$mod
$names.size
for table_ix, occ in $names
$table_ix
$occ
i.e. we put the module just once, followed by all names in that module.
When deserializing, we deserialize the module just once, and all the
following `Name`s are constructed with a pointer to that same decoded
`Module`.
In `hoogle-test`, we must use `DNameEnv` rather than `Map Name`,
otherwise the output fixities order was susceptible to changes in the
uniques assigned to each Names, which is not stable.
Fixes #27401
-------------------------
Metric Decrease:
InstanceMatching
LinkableUsage01
hard_hole_fits
-------------------------
- - - - -
b173c1e7 by Zubin Duggal at 2026-06-25T08:57:47-04:00
testsuite: Report fragile failures as skipped in JUnit output
- - - - -
13 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Unit/Module/Env.hs
- testsuite/driver/junit.py
- testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout
- testsuite/tests/rename/should_compile/T1792_imports.stdout
- testsuite/tests/rename/should_compile/T18264.stdout
- testsuite/tests/rename/should_compile/T4239.stdout
- testsuite/tests/showIface/DocsInHiFile1.stdout
- testsuite/tests/showIface/DocsInHiFileTH.stdout
- testsuite/tests/showIface/NoExportList.stdout
- testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
Changes:
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -37,7 +37,6 @@ import GHC.Unit
import GHC.Unit.Module.ModIface
import GHC.Types.Name
import GHC.Platform.Profile
-import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Data.FastMutInt
@@ -61,7 +60,8 @@ import System.IO.Unsafe
import Data.Typeable (Typeable)
import qualified GHC.Data.Strict as Strict
import Data.Function ((&))
-
+import GHC.Types.Name.Env
+import Data.Maybe
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -618,25 +618,27 @@ initNameReaderTable cache = do
}
data BinSymbolTable = BinSymbolTable {
- bin_symtab_next :: !FastMutInt, -- The next index to use
- bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
- -- indexed by Name
+ bin_symtab_next :: !FastMutInt,
+ -- ^ The next index to use
+ bin_symtab_map :: !(IORef (NameEnv Int, ModuleEnv [(Int,Name)]))
+ -- ^ Deduplication indexed by Name
+ -- ; Group table data by module for serialization
}
initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
initNameWriterTable = do
symtab_next <- newFastMutInt 0
- symtab_map <- newIORef emptyUFM
+ symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv)
let bin_symtab =
BinSymbolTable
{ bin_symtab_next = symtab_next
- , bin_symtab_map = symtab_map
+ , bin_symtab_map = symtab_map
}
let put_symtab bh = do
name_count <- readFastMutInt symtab_next
- symtab_map <- readIORef symtab_map
- putSymbolTable bh name_count symtab_map
+ (_, symtab_tbl) <- readIORef symtab_map
+ putSymbolTable bh name_count symtab_tbl
pure name_count
return
@@ -647,40 +649,53 @@ initNameWriterTable = do
)
-putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
+{- |
+The symbol table payload will look like:
+
+ <total name count>
+ $modules.size
+ for (mod, names) in $modules:
+ $mod
+ $names.size
+ for table_ix, occ in $names
+ $table_ix
+ $occ
+-}
+putSymbolTable :: WriteBinHandle -> Int -> ModuleEnv [(Int, Name)] -> IO ()
putSymbolTable bh name_count symtab = do
put_ bh name_count
- let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
- -- It's OK to use nonDetEltsUFM here because the elements have
- -- indices that array uses to create order
- mapM_ (\n -> serialiseName bh n symtab) names
-
-
+ put_ bh (sizeModuleEnv symtab)
+ forM_ (moduleEnvToList symtab) $ \(mod,names) -> do
+ put_ bh mod
+ put_ bh (length names)
+ forM_ names $ \(table_ix, name) -> do
+ let occ = assertPpr (isExternalName name) (ppr name) (nameOccName name)
+ put_ bh table_ix
+ put_ bh occ
+
+-- | Decode the symbol table -- layout set by 'putSymbolTable'.
getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable bh name_cache = do
sz <- get bh :: IO Int
-- create an array of Names for the symbols and add them to the NameCache
updateNameCache' name_cache $ \cache0 -> do
- mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
- cache <- foldGet' (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
- let mod = mkModule uid mod_name
- case lookupOrigNameCache cache mod occ of
- Just name -> do
- writeArray mut_arr (fromIntegral i) name
- return cache
- Nothing -> do
- uniq <- takeUniqFromNameCache name_cache
- let name = mkExternalName uniq mod occ noSrcSpan
- new_cache = extendOrigNameCache cache mod occ name
- writeArray mut_arr (fromIntegral i) name
- return new_cache
- arr <- unsafeFreeze mut_arr
- return (cache, arr)
-
-serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
-serialiseName bh name _ = do
- let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
- put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
+ mods_sz <- get bh :: IO Int
+ cache <-
+ foldGet' (fromIntegral mods_sz) bh cache0 $ \_mod_ix (mod,mod_nms_sz) cache1 -> do
+ foldGet' (fromIntegral (mod_nms_sz::Int)) bh cache1 $ \_mod_nms_ix (table_ix, occ) cache2 -> do
+ case lookupOrigNameCache cache2 mod occ of
+ Just name -> do
+ writeArray mut_arr table_ix name
+ return cache2
+ Nothing -> do
+ uniq <- takeUniqFromNameCache name_cache
+ let name = mkExternalName uniq mod occ noSrcSpan
+ cache3 = extendOrigNameCache cache2 mod occ name
+ writeArray mut_arr table_ix name
+ return cache3
+ arr <- unsafeFreeze mut_arr
+ return (cache, arr)
-- Note [Symbol table representation of names]
@@ -714,16 +729,26 @@ putName BinSymbolTable{
.|. (fromIntegral u :: Word32))
| otherwise
- = do symtab_map <- readIORef symtab_map_ref
- case lookupUFM symtab_map name of
- Just (off,_) -> put_ bh (fromIntegral off :: Word32)
+ = do (symtab_map,symtab_tbl) <- readIORef symtab_map_ref
+ case lookupNameEnv symtab_map name of
+ Just off -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
- off <- readFastMutInt symtab_next
- -- massert (off < 2^(30 :: Int))
- writeFastMutInt symtab_next (off+1)
- writeIORef symtab_map_ref
- $! addToUFM symtab_map name (off,name)
- put_ bh (fromIntegral off :: Word32)
+ off <- freshIndex
+ let mod = nameModule name
+ let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod)
+
+ let !symtab_map' = extendNameEnv symtab_map name off
+ let !symtab_tbl' = extendModuleEnv symtab_tbl mod ((off,name):mod_nms)
+ writeIORef symtab_map_ref $! ( symtab_map', symtab_tbl' )
+
+ put_ bh (fromIntegral off :: Word32)
+ where
+ freshIndex :: IO Int
+ freshIndex = do
+ off <- readFastMutInt symtab_next
+ -- massert (off < 2^(30 :: Int))
+ writeFastMutInt symtab_next (off+1)
+ return off
-- See Note [Symbol table representation of names]
getSymtabName :: SymbolTable Name
=====================================
compiler/GHC/Unit/Module/Env.hs
=====================================
@@ -9,7 +9,7 @@ module GHC.Unit.Module.Env
, alterModuleEnv
, partitionModuleEnv
, moduleEnvKeys, moduleEnvElts, moduleEnvToList
- , unitModuleEnv, isEmptyModuleEnv
+ , unitModuleEnv, isEmptyModuleEnv, sizeModuleEnv
, extendModuleEnvWith, filterModuleEnv, mapMaybeModuleEnv
-- * ModuleName mappings
@@ -176,6 +176,9 @@ unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x)
isEmptyModuleEnv :: ModuleEnv a -> Bool
isEmptyModuleEnv (ModuleEnv e) = Map.null e
+sizeModuleEnv :: ModuleEnv a -> Int
+sizeModuleEnv (ModuleEnv e) = Map.size e
+
-- | A set of 'Module's
type ModuleSet = Set NDModule
=====================================
testsuite/driver/junit.py
=====================================
@@ -14,12 +14,13 @@ def junit(t: TestRun) -> ET.ElementTree:
+ len(t.unexpected_stat_failures)
+ len(t.unexpected_passes)),
errors = str(len(t.framework_failures)),
+ skipped = str(len(t.fragile_failures)),
timestamp = datetime.now().isoformat())
- for res_type, group in [('stat failure', t.unexpected_stat_failures),
- ('unexpected failure', t.unexpected_failures),
- ('unexpected pass', t.unexpected_passes),
- ('fragile failure', t.fragile_failures)]:
+ for kind, res_type, group in [('failure', 'stat failure', t.unexpected_stat_failures),
+ ('failure', 'unexpected failure', t.unexpected_failures),
+ ('failure', 'unexpected pass', t.unexpected_passes),
+ ('skipped', 'fragile failure', t.fragile_failures)]:
for tr in group:
testcase = ET.SubElement(testsuite, 'testcase',
classname = tr.way,
@@ -30,7 +31,7 @@ def junit(t: TestRun) -> ET.ElementTree:
if tr.stderr:
message += ['', 'stderr:', '==========', tr.stderr]
- result = ET.SubElement(testcase, 'failure',
+ result = ET.SubElement(testcase, kind,
type = res_type,
message = tr.reason)
result.text = '\n'.join(message)
=====================================
testsuite/tests/overloadedrecflds/should_compile/DRFPatSynExport.stdout
=====================================
@@ -1 +1 @@
-import DRFPatSynExport_A ( MkT, m )
+import DRFPatSynExport_A ( m, MkT )
=====================================
testsuite/tests/rename/should_compile/T1792_imports.stdout
=====================================
@@ -1 +1 @@
-import qualified Data.ByteString as B ( putStr, readFile )
+import qualified Data.ByteString as B ( readFile, putStr )
=====================================
testsuite/tests/rename/should_compile/T18264.stdout
=====================================
@@ -1,6 +1,6 @@
import Data.Char ( isDigit, isLetter )
import Data.List ( sortOn )
-import Data.Maybe ( fromJust, isJust )
+import Data.Maybe ( isJust, fromJust )
import qualified Data.Char as C ( isLetter, isDigit )
import qualified Data.List as S ( sort )
import qualified Data.List as T ( nub )
=====================================
testsuite/tests/rename/should_compile/T4239.stdout
=====================================
@@ -1 +1 @@
-import T4239A ( (·), type (:+++)((:---), (:+++), X) )
+import T4239A ( type (:+++)((:---), (:+++), X), (·) )
=====================================
testsuite/tests/showIface/DocsInHiFile1.stdout
=====================================
@@ -19,49 +19,53 @@ docs:
export docs:
[]
declaration docs:
- [elem -> [text:
- -- | '()', 'elem'.
- identifiers:
- {DocsInHiFile.hs:14:13-16}
- GHC.Internal.Data.Foldable.elem
- {DocsInHiFile.hs:14:13-16}
- elem],
- D -> [text:
- -- | A datatype.
+ [F -> [text:
+ -- | A type family
identifiers:],
- D0 -> [text:
- -- ^ A constructor for 'D'. '
- identifiers:
- {DocsInHiFile.hs:20:32}
- D],
- D1 -> [text:
- -- ^ Another constructor
+ D:R:FInt -> [text:
+ -- | A type family instance
+ identifiers:],
+ D' -> [text:
+ -- | Another datatype...
+ identifiers:,
+ text:
+ -- ^ ...with two docstrings.
identifiers:],
- P -> [text:
- -- | A class
- identifiers:],
- p -> [text:
- -- | A class method
- identifiers:],
$fShowD -> [text:
-- ^ 'Show' instance
identifiers:
{DocsInHiFile.hs:22:25-28}
GHC.Internal.Show.Show],
- D' -> [text:
- -- | Another datatype...
- identifiers:,
- text:
- -- ^ ...with two docstrings.
+ p -> [text:
+ -- | A class method
+ identifiers:],
+ P -> [text:
+ -- | A class
+ identifiers:],
+ D1 -> [text:
+ -- ^ Another constructor
identifiers:],
- D:R:FInt -> [text:
- -- | A type family instance
- identifiers:],
- F -> [text:
- -- | A type family
- identifiers:]]
+ D0 -> [text:
+ -- ^ A constructor for 'D'. '
+ identifiers:
+ {DocsInHiFile.hs:20:32}
+ D],
+ D -> [text:
+ -- | A datatype.
+ identifiers:],
+ elem -> [text:
+ -- | '()', 'elem'.
+ identifiers:
+ {DocsInHiFile.hs:14:13-16}
+ GHC.Internal.Data.Foldable.elem
+ {DocsInHiFile.hs:14:13-16}
+ elem]]
arg docs:
- [add -> 0:
+ [p -> 0:
+ text:
+ -- ^ An argument
+ identifiers:,
+ add -> 0:
text:
-- ^ First summand for 'add'
identifiers:
@@ -74,11 +78,7 @@ docs:
2:
text:
-- ^ Sum
- identifiers:,
- p -> 0:
- text:
- -- ^ An argument
- identifiers:]
+ identifiers:]
documentation structure:
avails:
[elem]
=====================================
testsuite/tests/showIface/DocsInHiFileTH.stdout
=====================================
@@ -6,137 +6,153 @@ docs:
export docs:
[]
declaration docs:
- [Tup2 -> [text:
- -- |Matches a tuple of (a, a)
- identifiers:],
- f -> [text:
- -- |The meaning of life
- identifiers:],
- g -> [text:
- -- |Some documentation
- identifiers:],
- qux -> [text:
- -- |This is qux
+ [D:R:WD13Foo -> [text:
+ -- |13
+ identifiers:],
+ D:R:WD11Int0 -> [text:
+ -- |This is a data instance
+ identifiers:],
+ D:R:WD11Foo0 -> [text:
+ -- |11
+ identifiers:],
+ D:R:WD11Bool0 -> [text:
+ -- |This is a newtype instance
+ identifiers:],
+ D:R:EBool -> [text:
+ -- |A type family instance
+ identifiers:],
+ $fF -> [text:
+ -- |14
identifiers:],
- sin -> [text:
- -- |15
+ $fDka -> [text:
+ -- |Another new instance
+ identifiers:],
+ $fCTYPEList -> [text:
+ -- |Another new instance
+ identifiers:],
+ $fCTYPEInt -> [text:
+ -- |A new instance
+ identifiers:],
+ $fCTYPEFoo -> [text:
+ -- |7
+ identifiers:],
+ WD6 -> [text:
+ -- |6
identifiers:],
- wd1 -> [text:
- -- |1
+ WD5 -> [text:
+ -- |5
identifiers:],
- wd17 -> [text:
- -- |17
+ WD4 -> [text:
+ -- |4
+ identifiers:],
+ WD3 -> [text:
+ -- |3
+ identifiers:],
+ WD12 -> [text:
+ -- |12
identifiers:],
- wd18 -> [text:
- -- |18
+ WD11Int -> [text:
+ -- |This is a data instance constructor
+ identifiers:],
+ WD11Bool -> [text:
+ -- |This is a newtype instance constructor
+ identifiers:],
+ WD10 -> [text:
+ -- |10
identifiers:],
- wd2 -> [text:
- -- |2
- identifiers:],
- wd20 -> [text:
- -- |20
+ quuz1_a -> [text:
+ -- |This is the record constructor's argument
+ identifiers:],
+ Quuz -> [text:
+ -- |This is a record constructor
identifiers:],
- wd8 -> [text:
- -- |8
+ Quux2 -> [text:
+ -- |This is Quux2
+ identifiers:],
+ Quux1 -> [text:
+ -- |This is Quux1
+ identifiers:],
+ Quux -> [text:
+ -- |This is Quux
+ identifiers:],
+ prettyPrint -> [text:
+ -- |Prettily prints the object
+ identifiers:],
+ Pretty -> [text:
+ -- |My cool class
+ identifiers:],
+ Foo -> [text:
+ -- |A new constructor
identifiers:],
- C -> [text:
- -- |A new class
+ Foo -> [text:
+ -- |A new data type
+ identifiers:],
+ E -> [text:
+ -- |A type family
identifiers:],
- Corge -> [text:
- -- |This is a newtype record constructor
- identifiers:],
runCorge -> [text:
-- |This is the newtype record constructor's argument
identifiers:],
- E -> [text:
- -- |A type family
+ Corge -> [text:
+ -- |This is a newtype record constructor
+ identifiers:],
+ C -> [text:
+ -- |A new class
identifiers:],
- Foo -> [text:
- -- |A new data type
- identifiers:],
- Foo -> [text:
- -- |A new constructor
+ wd8 -> [text:
+ -- |8
identifiers:],
- Pretty -> [text:
- -- |My cool class
- identifiers:],
- prettyPrint -> [text:
- -- |Prettily prints the object
- identifiers:],
- Quux -> [text:
- -- |This is Quux
- identifiers:],
- Quux1 -> [text:
- -- |This is Quux1
- identifiers:],
- Quux2 -> [text:
- -- |This is Quux2
- identifiers:],
- Quuz -> [text:
- -- |This is a record constructor
+ wd20 -> [text:
+ -- |20
identifiers:],
- quuz1_a -> [text:
- -- |This is the record constructor's argument
- identifiers:],
- WD10 -> [text:
- -- |10
+ wd2 -> [text:
+ -- |2
+ identifiers:],
+ wd18 -> [text:
+ -- |18
identifiers:],
- WD11Bool -> [text:
- -- |This is a newtype instance constructor
- identifiers:],
- WD11Int -> [text:
- -- |This is a data instance constructor
- identifiers:],
- WD12 -> [text:
- -- |12
+ wd17 -> [text:
+ -- |17
identifiers:],
- WD3 -> [text:
- -- |3
- identifiers:],
- WD4 -> [text:
- -- |4
- identifiers:],
- WD5 -> [text:
- -- |5
+ wd1 -> [text:
+ -- |1
identifiers:],
- WD6 -> [text:
- -- |6
+ sin -> [text:
+ -- |15
identifiers:],
- $fCTYPEFoo -> [text:
- -- |7
- identifiers:],
- $fCTYPEInt -> [text:
- -- |A new instance
- identifiers:],
- $fCTYPEList -> [text:
- -- |Another new instance
- identifiers:],
- $fDka -> [text:
- -- |Another new instance
- identifiers:],
- $fF -> [text:
- -- |14
+ qux -> [text:
+ -- |This is qux
identifiers:],
- D:R:EBool -> [text:
- -- |A type family instance
- identifiers:],
- D:R:WD11Bool0 -> [text:
- -- |This is a newtype instance
- identifiers:],
- D:R:WD11Foo0 -> [text:
- -- |11
- identifiers:],
- D:R:WD11Int0 -> [text:
- -- |This is a data instance
- identifiers:],
- D:R:WD13Foo -> [text:
- -- |13
- identifiers:]]
+ g -> [text:
+ -- |Some documentation
+ identifiers:],
+ f -> [text:
+ -- |The meaning of life
+ identifiers:],
+ Tup2 -> [text:
+ -- |Matches a tuple of (a, a)
+ identifiers:]]
arg docs:
- [Tup2 -> 0:
- text:
- -- |The thing to match twice
- identifiers:,
+ [WD11Int -> 0:
+ text:
+ -- |This is a data instance constructor argument
+ identifiers:,
+ WD11Bool -> 0:
+ text:
+ -- |This is a newtype instance constructor argument
+ identifiers:,
+ Quux2 -> 1:
+ text:
+ -- |I am a bool
+ identifiers:,
+ Quux1 -> 0:
+ text:
+ -- |I am an integer
+ identifiers:,
+ qux -> 1:
+ text:
+ -- |Arg dos
+ identifiers:,
h -> 0:
text:
-- ^Your favourite number
@@ -149,26 +165,10 @@ docs:
text:
-- ^A return value
identifiers:,
- qux -> 1:
- text:
- -- |Arg dos
- identifiers:,
- Quux1 -> 0:
- text:
- -- |I am an integer
- identifiers:,
- Quux2 -> 1:
- text:
- -- |I am a bool
- identifiers:,
- WD11Bool -> 0:
- text:
- -- |This is a newtype instance constructor argument
- identifiers:,
- WD11Int -> 0:
- text:
- -- |This is a data instance constructor argument
- identifiers:]
+ Tup2 -> 0:
+ text:
+ -- |The thing to match twice
+ identifiers:]
documentation structure:
avails:
[f]
=====================================
testsuite/tests/showIface/NoExportList.stdout
=====================================
@@ -6,7 +6,10 @@ docs:
export docs:
[]
declaration docs:
- [fα -> [text:
+ [$fEqR -> [text:
+ -- | A very lazy Eq instance
+ identifiers:],
+ fα -> [text:
-- ^ Documentation for 'R'\'s 'fα' field.
identifiers:
{NoExportList.hs:14:38}
@@ -14,10 +17,7 @@ docs:
{NoExportList.hs:14:38}
R
{NoExportList.hs:14:45-46}
- fα],
- $fEqR -> [text:
- -- | A very lazy Eq instance
- identifiers:]]
+ fα]]
arg docs:
[]
documentation structure:
@@ -99,3 +99,4 @@ docs:
ListTuplePuns
ImplicitStagePersistence
extensible fields:
+
=====================================
testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr
=====================================
@@ -5,10 +5,10 @@ subsumption_sort_hole_fits.hs:2:5: warning: [GHC-88464] [-Wtyped-holes (in -Wdef
• Relevant bindings include
f :: [String] (bound at subsumption_sort_hole_fits.hs:2:1)
Valid hole fits include
- lines :: String -> [String]
+ words :: String -> [String]
(imported from ‘Prelude’
(and originally defined in ‘GHC.Internal.Data.OldList’))
- words :: String -> [String]
+ lines :: String -> [String]
(imported from ‘Prelude’
(and originally defined in ‘GHC.Internal.Data.OldList’))
repeat :: forall a. a -> [a]
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
=====================================
@@ -251,10 +251,12 @@ attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity getIns
}
where
fixities :: [(Name, Fixity)]
- !fixities = force . Map.toList $ List.foldl' f Map.empty all_names
+ -- Use DNameEnv to guarantee a deterministic output regardless of the
+ -- uniques assigned to each_name e.g. off of the interface file.
+ !fixities = force . eltsDNameEnv $ List.foldl' f emptyDNameEnv all_names
- f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity
- f !fs n = Map.alter (<|> getFixity n) n fs
+ f :: DNameEnv (Name, Fixity) -> Name -> DNameEnv (Name, Fixity)
+ f !fs n = alterDNameEnv (<|> ((,) n <$> getFixity n)) fs n
patsyn_names :: [Name]
patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -40,6 +40,7 @@ import Data.Coerce (coerce)
import Data.Function ((&))
import Data.IORef
import Data.Map (Map)
+import Data.Maybe (fromMaybe)
import Data.Version
import Data.Word
import GHC hiding (NoLink)
@@ -50,7 +51,9 @@ import GHC.Iface.Type (IfaceType, putIfaceType)
import GHC.Types.Name.Cache
import GHC.Types.Unique
import GHC.Types.Unique.FM
+import GHC.Types.Name.Env
import GHC.Unit.State
+import GHC.Unit.Module.Env
import GHC.Utils.Binary
import Haddock.Types
import Text.ParserCombinators.ReadP (readP_to_S)
@@ -171,7 +174,7 @@ writeInterfaceFile filename iface = do
-- Make some intial state
symtab_next <- newFastMutInt 0
- symtab_map <- newIORef emptyUFM
+ symtab_map <- newIORef (emptyNameEnv, emptyModuleEnv)
let bin_symtab =
BinSymbolTable
{ bin_symtab_next = symtab_next
@@ -211,8 +214,8 @@ writeInterfaceFile filename iface = do
-- write the symbol table itself
symtab_next' <- readFastMutInt symtab_next
- symtab_map' <- readIORef symtab_map
- putSymbolTable bh symtab_next' symtab_map'
+ (_, symtab_tbl') <- readIORef symtab_map
+ putSymbolTable bh symtab_next' symtab_tbl'
-- write the dictionary pointer at the fornt of the file
dict_p <- tellBinWriter bh
@@ -269,20 +272,30 @@ putName
bh
name =
do
- symtab_map <- readIORef symtab_map_ref
- case lookupUFM symtab_map name of
- Just (off, _) -> put_ bh (fromIntegral off :: Word32)
+ (symtab_map, symtab_tbl) <- readIORef symtab_map_ref
+ case lookupNameEnv symtab_map name of
+ Just off -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
- off <- readFastMutInt symtab_next
- writeFastMutInt symtab_next (off + 1)
- writeIORef symtab_map_ref $!
- addToUFM symtab_map name (off, name)
+ off <- freshIndex
+ let mod' = nameModule name
+ let mod_nms = fromMaybe [] (lookupModuleEnv symtab_tbl mod')
+
+ let !symtab_map' = extendNameEnv symtab_map name off
+ let !symtab_tbl' = extendModuleEnv symtab_tbl mod' ((off, name):mod_nms)
+ writeIORef symtab_map_ref $! (symtab_map', symtab_tbl')
put_ bh (fromIntegral off :: Word32)
+ where
+ freshIndex :: IO Int
+ freshIndex = do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off + 1)
+ return off
data BinSymbolTable = BinSymbolTable
{ bin_symtab_next :: !FastMutInt -- The next index to use
- , bin_symtab_map :: !(IORef (UniqFM Name (Int, Name)))
- -- indexed by Name
+ , bin_symtab_map :: !(IORef (NameEnv Int, ModuleEnv [(Int, Name)]))
+ -- ^ Deduplication indexed by Name
+ -- ; Group table data by module for serialization
}
putFastString :: BinDictionary -> WriteBinHandle -> FastString -> IO ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/263c433c94d4f62bacfe12ba6c60c8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/263c433c94d4f62bacfe12ba6c60c8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/remove-ddump-json] 10 commits: Add explicit setBit/clearBit/complementBit for instance Bits Integer (#21176)
by Simon Hengel (＠sol) 25 Jun '26
by Simon Hengel (＠sol) 25 Jun '26
25 Jun '26
Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
Commits:
f235d183 by Simon Jakobi at 2026-06-25T05:51:18-04:00
Add explicit setBit/clearBit/complementBit for instance Bits Integer (#21176)
The default setBit, clearBit, and complementBit methods allocate
intermediate Integers per call. Define them explicitly via the new
integerSetBit[#], integerClearBit[#] and integerComplementBit[#], built
on the BigNat# primitives, which avoid those allocations. Allocation is not
eliminated entirely -- the negative (IN) cases would need in-place mutation,
which is left as future work.
The default methods constant-folded on literal arguments via the
integerOr/integerAnd/integerXor rules, which fold literal Integers of any
size. The explicit functions have no such rule, so they (their Word-argument
wrappers, and the Bits Integer methods) are marked INLINE to expose the
underlying primops to the simplifier; see Note [INLINE for constant folding
of bit operations]. This restores folding only on the small-int (IS) path --
large literal Integers (IP/IN) are no longer constant-folded, a minor
regression for that case. T8832 covers the IS-path folding.
The new golden-output test T21176 checks all three operations against the
default implementations across the sign/size boundaries, recording each
result plus its integerCheck validity. The base and ghc-bignum interface-
stability export goldens gain the new functions.
The main changelog entry lives in changelog.d under a new ghc-internal
section (renamed from ghc-prim).
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/423
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
202ed264 by Marc Scholten at 2026-06-25T05:52:21-04:00
haddock: use Text in documentation pipeline
This patch moves Haddock's documentation pipeline from String to Text
where the data is already textual. It avoids repeated conversions while
keeping the existing decoding behavior for invalid UTF-8 docstring
chunks.
The main changes are:
* Render and carry docstrings as Text in Haddock-facing paths.
* Use the Binary Text instance from GHC.Utils.Binary for Haddock
interface files, and bump the Haddock binary interface version.
* Add a FastString HTML instance so XHTML rendering avoids
intermediate String allocation.
* Keep HsDocStringChunk decoding lenient, matching the previous
unpackHDSC behavior on invalid UTF-8 input.
* Update the xhtml submodule to 3000.4.1.0, which contains the
apostrophe escaping fix used by the Haddock test output.
Co-authored-by: copilot-swe-agent[bot] <198982749+Copilot(a)users.noreply.github.com>
Co-authored-by: Claude Opus 4.5 <noreply(a)anthropic.com>
Assisted-by: Codex <codex(a)openai.com>
- - - - -
a72ff58f by mangoiv at 2026-06-25T05:53:07-04:00
compiler: rename ZonkAny to UnusedType and add pretty printing logic
ZonkAny is a hard to understand name for users who do not know how the
compiler works internally. Additionally, it is confusing that ZonkAny,
while being a concrete type *represents* a meta variable, espeically in
the compiler output.
This patch changes the name of ZonkAny to UnusedType which is closer to
its intended semantics and adds special pretty printing logic to display
this type in the same fashion the compiler displays meta variables in
other places, whenever they leak from the implementation to the user.
It also exports the type from ghc-internal:GHC.Internal.Types in order
to expose documentation.
Fixes #27390
Co-Authored-By: Sam Derbyshire <sam.derbyshire(a)gmail.com>
- - - - -
935467ed by Simon Hengel at 2026-06-25T19:39:02+07:00
Rename `MCDiagnostic` to `InternalMCDiagnostic`
`MCDiagnostic` is meant to be used for compiler diagnostics.
Any code that creates `MCDiagnostic` directly, without going through
`GHC.Driver.Errors.printMessage`, sidesteps `-fdiagnostics-as-json` (see
e.g. !14616, !14475, !14492 !14548).
To avoid this in the future, this change more narrowly controls who
creates `MCDiagnostic` (see #24113).
- - - - -
6f85922b by Simon Hengel at 2026-06-25T19:50:03+07:00
Remove -ddump-json (fixes #24113)
- - - - -
dd84da16 by Simon Hengel at 2026-06-25T19:50:03+07:00
Add SrcSpan to MCDiagnostic
- - - - -
4b5d41f7 by Simon Hengel at 2026-06-25T19:50:03+07:00
Get rid of mkLocMessage
- - - - -
e89e7e32 by Simon Hengel at 2026-06-25T19:50:03+07:00
Add Message data type
- - - - -
c7f60621 by Simon Hengel at 2026-06-25T19:50:03+07:00
Get rid of MessageClass
- - - - -
fcf52d24 by Simon Hengel at 2026-06-25T19:50:03+07:00
Remove JSON logging
- - - - -
107 changed files:
- + changelog.d/T21176
- changelog.d/config
- + changelog.d/unused-type
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/LogQueue.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Error.hs
- − compiler/GHC/Types/Error.hs-boot
- compiler/GHC/Types/SourceError.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- libraries/base/changelog.md
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-bignum/changelog.md
- libraries/ghc-experimental/src/GHC/PrimOps.hs
- libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs
- libraries/ghc-internal/src/GHC/Internal/Bits.hs
- libraries/ghc-internal/src/GHC/Internal/Types.hs
- libraries/xhtml
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
- testsuite/tests/ghc-api/T7478/T7478.hs
- testsuite/tests/interface-stability/ghc-bignum-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/numeric/should_run/T21176.hs
- + testsuite/tests/numeric/should_run/T21176.stdout
- + testsuite/tests/numeric/should_run/T21176.stdout-ws-32
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/perf/compiler/T11068.stdout
- testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs
- testsuite/tests/pmcheck/should_compile/T12957.stderr
- testsuite/tests/profiling/should_run/staticcallstack002.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T13156.stdout
- testsuite/tests/simplCore/should_compile/T26615.stderr
- testsuite/tests/simplCore/should_compile/T8832.hs
- testsuite/tests/simplCore/should_compile/T8832.stdout
- testsuite/tests/typecheck/should_fail/T13292.stderr
- + testsuite/tests/typecheck/should_fail/T27390-explicit-kinds.stderr
- + testsuite/tests/typecheck/should_fail/T27390.hs
- + testsuite/tests/typecheck/should_fail/T27390.stderr
- + testsuite/tests/typecheck/should_fail/T27390a.hs
- testsuite/tests/typecheck/should_fail/all.T
- utils/check-exact/Main.hs
- utils/check-exact/Preprocess.hs
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Doc.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Json.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Options.hs
- utils/haddock/haddock-api/src/Haddock/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/haddock/haddock-api/src/Haddock/Utils/Json.hs
- utils/haddock/haddock-api/src/Haddock/Utils/Json/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Utils/Json/Types.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Doc.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Markup.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser/Util.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Types.hs
- utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f8c5b27454cf665394cbbc31afd7d9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f8c5b27454cf665394cbbc31afd7d9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0