Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00 Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic' - Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type' - Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic' - Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'. - Replace all call sites of the original 'hsQTvExplicit' definition with either: 1. 'hsQTvExplicit' updated definition 2. 'hsQTvExplicitBinders' All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible. These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed. - - - - - 5 changed files: - compiler/GHC/Hs/Type.hs - compiler/Language/Haskell/Syntax/Type.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs Changes: ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -640,6 +640,9 @@ hsLTyVarName = hsTyVarName . unLoc hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = mapMaybe hsLTyVarName +hsQTvExplicit :: LHsQTyVars (GhcPass p) -> [LHsTyVarBndr (HsBndrVis (GhcPass p)) (GhcPass p)] +hsQTvExplicit = hsq_explicit + hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] hsForAllTelescopeBndrs (HsForAllVis _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -55,7 +55,6 @@ module Language.Haskell.Syntax.Type ( FieldOcc(..), LFieldOcc, mapHsOuterImplicit, - hsQTvExplicit, isHsKindedTyVar ) where @@ -68,7 +67,6 @@ import Language.Haskell.Syntax.Specificity import GHC.Hs.Doc (LHsDoc) import GHC.Data.FastString (FastString) -import GHC.Utils.Panic( panic ) import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe @@ -326,10 +324,6 @@ data LHsQTyVars pass -- See Note [HsType binders] } | XLHsQTyVars !(XXLHsQTyVars pass) -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass] -hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs -hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit" - ------------------------------------------------ -- HsOuterTyVarBndrs -- Used to quantify the outermost type variable binders of a type that obeys ===================================== utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs ===================================== @@ -435,7 +435,7 @@ ppFamHeader | associated = id | otherwise = (<+> keyword "family") - famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) + famName = ppAppDocNameTyVarBndrs unicode name (hsQTvExplicitBinders tvs) famSig = case result of NoSig _ -> empty @@ -644,7 +644,7 @@ ppTyVars :: RenderableBndrFlag flag => Bool -> [LHsTyVarBndr flag DocNameI] -> [ ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs tyvarNames :: LHsQTyVars DocNameI -> [Maybe Name] -tyvarNames = map (fmap getName . hsLTyVarNameI) . hsQTvExplicit +tyvarNames = map (fmap getName . hsLTyVarNameI) . hsQTvExplicitBinders declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -468,7 +468,7 @@ ppTySyn hdr = hsep ( [keyword "type", ppBinder summary occ] - ++ ppTyVars unicode qual (hsQTvExplicit ltyvars) + ++ ppTyVars unicode qual (hsQTvExplicitBinders ltyvars) ) full = hdr <+> def def = case unLoc ltype of @@ -595,7 +595,7 @@ ppFamHeader qual = hsep [ ppFamilyLeader associated info - , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs) + , ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicitBinders tvs) , ppResultSig result unicode qual , injAnn , whereBit @@ -760,7 +760,7 @@ ppClassHdr ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) - <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) + <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicitBinders tvs) <+> ppFds fds unicode qual ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html @@ -1656,7 +1656,7 @@ ppDataHeader ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b - ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs) + ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicitBinders tvs) <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -333,9 +333,12 @@ lHsQTyVarsToTypes tvs = [ HsValArg noExtField $ noLocA (case hsLTyVarName tv of Nothing -> HsWildCardTy noExtField Just nm -> HsTyVar noAnn NotPromoted (noLocA $ noUserRdr nm)) - | tv <- hsQTvExplicit tvs + | tv <- hsq_explicit tvs ] +hsQTvExplicitBinders :: LHsQTyVars DocNameI -> [LHsTyVarBndr (HsBndrVis DocNameI) DocNameI] +hsQTvExplicitBinders = hsq_explicit + -------------------------------------------------------------------------------- -- * Making abstract declarations View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06c2349c41e4fba7ca80ee97506b2265... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06c2349c41e4fba7ca80ee97506b2265... You're receiving this email because of your account on gitlab.haskell.org.