[Git][ghc/ghc][wip/T25281] Remove more incomplete record selectors
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Oct 2 23:18:56 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
893bfd1e by Simon Peyton Jones at 2024-10-03T00:13:55+01:00
Remove more incomplete record selectors
- - - - -
7 changed files:
- compiler/GHC/Core/Rules.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Quote.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/Core/Rules.hs
=====================================
@@ -30,7 +30,8 @@ module GHC.Core.Rules (
rulesOfBinds, getRules, pprRulesForUser,
-- * Making rules
- mkRule, mkSpecRule, roughTopNames
+ mkRule, mkSpecRule, roughTopNames,
+ ruleIsOrphan
) where
@@ -484,6 +485,10 @@ ruleIsVisible _ BuiltinRule{} = True
ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }
= notOrphan orph || origin `elemModuleSet` vis_orphs
+ruleIsOrphan :: CoreRule -> Bool
+ruleIsOrphan (BuiltinRule {}) = False
+ruleIsOrphan (Rule { ru_orphan = orph }) = isOrphan orph
+
{- Note [Where rules are found]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The rules for an Id come from two places:
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -907,7 +907,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
dsWarnOrphanRule :: CoreRule -> DsM ()
dsWarnOrphanRule rule
- = when (isOrphan (ru_orphan rule)) $
+ = when (ruleIsOrphan rule) $
diagnosticDs (DsOrphanRule rule)
{- Note [SPECIALISE on INLINE functions]
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -182,7 +182,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- Divide into sub-groups; see Note [Record patterns]
; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE))
groups = NE.groupBy1 compatible_pats
- $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
+ $ fmap (\eqn -> (con_pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
; match_results <- mapM (match_group arg_vars) groups
@@ -191,6 +191,10 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
+ con_pat_args :: Pat GhcTc -> HsConPatDetails GhcTc
+ con_pat_args (ConPat { pat_args = args }) = args
+ con_pat_args p = pprPanic "matchOneConLike" (ppr p) -- All patterns are ConPats
+
ConPat { pat_con = L _ con1
, pat_args = args1
, pat_con_ext = ConPatTc
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -2158,7 +2158,8 @@ repP (ConPat NoExtField dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon tyargs ps -> do { qs <- repLPs ps
- ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hstp_body t)
+ ; let unwrapTyArg (HsConPatTyArg _ (t :: HsTyPat GhcRn))
+ = unLoc (hstp_body t)
; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs
; repPcon con_str ts qs }
RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -244,7 +244,7 @@ isSimpleSig
}
)
)
- | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
+ | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCardsI t))
isSimpleSig _ = Nothing
isExportModule :: ExportItem DocNameI -> Maybe Module
@@ -327,7 +327,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
TyClD _ d at DataDecl{} -> ppDataDecl pats instances subdocs (Just doc) d unicode
TyClD _ d at SynDecl{} -> ppTySyn (doc, fnArgsDoc) d unicode
TyClD _ d at ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCardsI ty) unicode
SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
InstD _ _ -> empty
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -82,7 +82,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
(locA loc)
(mbDoc, fnArgsDoc)
lnames
- (dropWildCards lty)
+ (dropWildCardsI lty)
fixities
splice
unicode
@@ -1146,7 +1146,7 @@ ppInstanceSigs
ppInstanceSigs links splice unicode qual sigs = do
TypeSig _ lnames typ <- sigs
let names = map unLoc lnames
- L _ rtyp = dropWildCards typ
+ L _ rtyp = dropWildCardsI typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
let lname =
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -149,6 +149,10 @@ getConNamesI ConDeclGADT{con_names = names} = names
hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
hsSigTypeI = sig_body . unLoc
+dropWildCardsI :: LHsSigWcType DocNameI -> LHsSigType DocNameI
+-- Drop the wildcard part of a LHsSigWcType
+dropWildCardsI sig_ty = hswc_body sig_ty
+
mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
-- Dubious, because the implicit binders are empty even
-- though the type might have free variables
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/893bfd1ee37c40c00529c361f5394c7e81a5322f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/893bfd1ee37c40c00529c361f5394c7e81a5322f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241002/a822e2ef/attachment-0001.html>
More information about the ghc-commits
mailing list