[Git][ghc/ghc][wip/T25281] 2 commits: Switch off -Wincomplete-record-selectors
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Oct 2 13:01:08 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
79a3add1 by Simon Peyton Jones at 2024-10-02T14:00:12+01:00
Switch off -Wincomplete-record-selectors
... because GHC uses quite a lot of them!
ToDo: fix the code so it doesn't.
- - - - -
9c4956e8 by Simon Peyton Jones at 2024-10-02T14:00:19+01:00
Fix incomplete record selections
Refactor code to avoid incomplete record selectors
(More to come.)
- - - - -
25 changed files:
- compiler/GHC/CmmToAsm/Dwarf/Types.hs
- compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Meta.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Panic.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- compiler/Language/Haskell/Syntax/Type.hs
- hadrian/src/Settings/Warnings.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/Dwarf/Types.hs
=====================================
@@ -150,14 +150,14 @@ pprAbbrevDecls platform haveDebugLine =
pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc
pprDwarfInfo platform haveSrc d
= case d of
- DwarfCompileUnit {} -> hasChildren
- DwarfSubprogram {} -> hasChildren
- DwarfBlock {} -> hasChildren
- DwarfSrcNote {} -> noChildren
+ DwarfCompileUnit {dwChildren = kids} -> hasChildren kids
+ DwarfSubprogram {dwChildren = kids} -> hasChildren kids
+ DwarfBlock {dwChildren = kids} -> hasChildren kids
+ DwarfSrcNote {} -> noChildren
where
- hasChildren =
+ hasChildren kids =
pprDwarfInfoOpen platform haveSrc d $$
- vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
+ vcat (map (pprDwarfInfo platform haveSrc) kids) $$
pprDwarfInfoClose
noChildren = pprDwarfInfoOpen platform haveSrc d
{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-}
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
=====================================
@@ -219,11 +219,10 @@ pprStatsSpills
pprStatsSpills stats
= let
- finals = [ s | s at RegAllocStatsColored{} <- stats]
+ finals = [srms | RegAllocStatsColored{ raSRMs = srms } <- stats]
-- sum up how many stores\/loads\/reg-reg-moves were left in the code
- total = foldl' addSRM (0, 0, 0)
- $ map raSRMs finals
+ total = foldl' addSRM (0, 0, 0) finals
in ( text "-- spills-added-total"
$$ text "-- (stores, loads, reg_reg_moves_remaining)"
@@ -237,8 +236,7 @@ pprStatsLifetimes
pprStatsLifetimes stats
= let info = foldl' plusSpillCostInfo zeroSpillCostInfo
- [ raSpillCosts s
- | s at RegAllocStatsStart{} <- stats ]
+ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ]
lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info
@@ -287,7 +285,7 @@ pprStatsLifeConflict
pprStatsLifeConflict stats graph
= let lifeMap = lifeMapFromSpillCostInfo
$ foldl' plusSpillCostInfo zeroSpillCostInfo
- $ [ raSpillCosts s | s at RegAllocStatsStart{} <- stats ]
+ $ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ]
scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of
Just (_, l) -> l
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1722,7 +1722,7 @@ mkFunResCo role id res_co
= mkFunCoNoFTF role mult arg_co res_co
where
arg_co = mkReflCo role (varType id)
- mult = multToCo (varMult id)
+ mult = multToCo (idMult id)
-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2
-- The first coercion might be lifted or unlifted; thus the ~? above
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -702,7 +702,7 @@ freeVars = go
| isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v)
| otherwise = (emptyDVarSet, AnnVar v)
where
- mult_vars = tyCoVarsOfTypeDSet (varMult v)
+ mult_vars = tyCoVarsOfTypeDSet (idMult v)
ty_fvs = dVarTypeTyCoVars v
-- See Note [The FVAnn invariant]
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1525,7 +1525,7 @@ lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs)
checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv
checkCaseLinearity ue case_bndr var_w bndr = do
ensureSubUsage lhs rhs err_msg
- lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr)
+ lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (idMult bndr)
return $ deleteUE ue bndr
where
lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage)
@@ -1538,7 +1538,7 @@ checkCaseLinearity ue case_bndr var_w bndr = do
lhs_formula = ppr bndr_usage <+> text "+"
<+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w)
rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w
- case_bndr_w = varMult case_bndr
+ case_bndr_w = idMult case_bndr
case_bndr_usage = lookupUE ue case_bndr
bndr_usage = lookupUE ue bndr
@@ -1625,7 +1625,7 @@ lintCaseExpr scrut var alt_ty alts =
; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut
-- See Note [Join points are less general than the paper]
-- in GHC.Core
- ; let scrut_mult = varMult var
+ ; let scrut_mult = idMult var
; alt_ty <- addLoc (CaseTy scrut) $
lintValueType alt_ty
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -339,7 +339,7 @@ cprTransform env id args
| isLocalId id
= assertPpr (isDataStructure id) (ppr id) topCprType
-- See Note [CPR for DataCon wrappers]
- | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)
+ | Just rhs <- dataConWrapUnfolding_maybe id
= fst $ cprAnalApp env rhs args
-- DataCon worker
| Just con <- isDataConWorkId_maybe id
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1015,7 +1015,7 @@ dmdTransform env var sd
= -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $
dmdTransformDataConSig (dataConRepStrictness con) sd
-- See Note [DmdAnal for DataCon wrappers]
- | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)
+ | Just rhs <- dataConWrapUnfolding_maybe var
, WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
= dmd_ty
-- Dictionary component selectors
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -1307,4 +1307,4 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv
no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w
subst = Subst in_scope emptyIdSubstEnv tv_env cv_env
old_ty = idType id
- old_w = varMult id
+ old_w = idMult id
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2819,8 +2819,9 @@ mkCase3 _mode scrut bndr alts_ty alts
isExitJoinId :: Var -> Bool
isExitJoinId id
= isJoinId id
- && isOneOcc (idOccInfo id)
- && occ_in_lam (idOccInfo id) == IsInsideLam
+ && case idOccInfo id of
+ OneOcc { occ_in_lam = IsInsideLam } -> True
+ _ -> False
{-
Note [Dead binders]
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -482,7 +482,7 @@ substIdType subst@(Subst _ _ tv_env cv_env) id
-- in a Note in the id's type itself
where
old_ty = idType id
- old_w = varMult id
+ old_w = idMult id
------------------
-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -180,7 +180,7 @@ mkLamType v body_ty
= mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty
| otherwise
- = mkFunctionType (varMult v) (varType v) body_ty
+ = mkFunctionType (idMult v) (idType v) body_ty
mkLamTypes vs ty = foldr mkLamType ty vs
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -652,10 +652,9 @@ pprTicks pp_no_debug pp_when_debug
then pp_when_debug
else pp_no_debug
-instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where
+instance Outputable (XRec (GhcPass p) RdrName) => Outputable (RecordPatSynField (GhcPass p)) where
ppr (RecordPatSynField { recordPatSynField = v }) = ppr v
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1529,6 +1529,11 @@ matchGroupArity (MG { mg_alts = alts })
hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats
+isInfixMatch :: Match (GhcPass p) body -> Bool
+isInfixMatch match = case m_ctxt match of
+ FunRhs {mc_fixity = Infix} -> True
+ _ -> False
+
-- We keep the type checker happy by providing EpAnnComments. They
-- can only be used if they follow a `where` keyword with no binds,
-- but in that case the comment is attached to the following parsed
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -39,7 +39,6 @@ module GHC.Hs.Pat (
RecFieldsDotDot(..),
hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
-
mkPrefixConPat, mkCharLitPat, mkNilPat,
isSimplePat, isPatSyn,
@@ -85,7 +84,9 @@ import GHC.Core.Type
import GHC.Types.SrcLoc
import GHC.Data.Bag -- collect ev vars from pats
import GHC.Types.Name
+
import Data.Data
+import qualified Data.List( map )
import qualified Data.List.NonEmpty as NE
@@ -338,6 +339,16 @@ data ConPatTc
cpt_wrap :: HsWrapper
}
+
+hsRecFields :: HsRecFields (GhcPass p) arg -> [XCFieldOcc (GhcPass p)]
+hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds)
+
+hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg]
+hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds)
+
+hsRecFieldSel :: HsRecField (GhcPass p) arg -> XCFieldOcc (GhcPass p)
+hsRecFieldSel = fieldOccExt . unLoc . hfbLHS
+
hsRecFieldId :: HsRecField GhcTc arg -> Id
hsRecFieldId = hsRecFieldSel
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -60,7 +60,7 @@ module GHC.Hs.Type (
HsConDetails(..), noTypeArgs,
- FieldOcc(..), LFieldOcc, mkFieldOcc,
+ FieldOcc(..), LFieldOcc, mkFieldOcc, fieldOccExt,
AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,
ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName,
selectorAmbiguousFieldOcc,
@@ -305,10 +305,14 @@ type instance XXHsTyPat (GhcPass _) = DataConCantHappen
type instance XHsSig (GhcPass _) = NoExtField
type instance XXHsSigType (GhcPass _) = DataConCantHappen
-hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p
-hsSigWcType = sig_body . unXRec @p . hswc_body
-dropWildCards :: LHsSigWcType pass -> LHsSigType pass
+hsPatSigType :: HsPatSigType (GhcPass p) -> LHsType (GhcPass p)
+hsPatSigType (HsPS { hsps_body = ty }) = ty
+
+hsSigWcType :: LHsSigWcType (GhcPass p) -> LHsType (GhcPass p)
+hsSigWcType = sig_body . unLoc . hswc_body
+
+dropWildCards :: LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p)
-- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = hswc_body sig_ty
@@ -1099,6 +1103,8 @@ type instance XXFieldOcc (GhcPass _) = DataConCantHappen
mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc rdr = FieldOcc noExtField rdr
+fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p)
+fieldOccExt (FieldOcc { foExt = ext }) = ext
type instance XUnambiguous GhcPs = NoExtField
type instance XUnambiguous GhcRn = Name
@@ -1270,14 +1276,16 @@ instance (Outputable tyarg, Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
-instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where
+instance Outputable (FieldOcc (GhcPass pass)) where
ppr = ppr . foLabel
-instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where
- pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel
- pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel
+instance (OutputableBndr (XRec (GhcPass p) RdrName))
+ => OutputableBndr (FieldOcc (GhcPass pass)) where
+ pprInfixOcc = pprInfixOcc . unLoc . foLabel
+ pprPrefixOcc = pprPrefixOcc . unLoc . foLabel
-instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where
+instance (OutputableBndr (XRec (GhcPass p) RdrName))
+ => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass p))) where
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -859,9 +859,9 @@ mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
-isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool
+isInfixFunBind :: HsBindLR (GhcPass p1) (GhcPass p2) -> Bool
isInfixFunBind (FunBind { fun_matches = MG _ matches })
- = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches)
+ = any (isInfixMatch . unLoc) (unLoc matches)
isInfixFunBind _ = False
-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds
@@ -1861,5 +1861,5 @@ rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })
where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds
implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))
= ImplicitFieldBinders
- { implFlBndr_field = foExt fld
+ { implFlBndr_field = fieldOccExt fld
, implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -610,7 +610,7 @@ tcPolyCheck prag_fn
; (wrap_gen, (wrap_res, matches'))
<- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty ->
- let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in
+ let mono_id = mkLocalId mono_name (idMult poly_id) rho_ty in
tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
-- Why mono_id in the BinderStack?
-- See Note [Relevant bindings and the binder stack]
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -71,7 +71,7 @@ module GHC.Types.Id (
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe,
- isDataConWrapId, isDataConWrapId_maybe,
+ isDataConWrapId, isDataConWrapId_maybe, dataConWrapUnfolding_maybe,
isDataConId, isDataConId_maybe,
idDataCon,
isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom,
@@ -129,10 +129,6 @@ module GHC.Types.Id (
import GHC.Prelude
-import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding
- , isCompulsoryUnfolding, Unfolding( NoUnfolding )
- , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding )
-
import GHC.Types.Id.Info
import GHC.Types.Basic
@@ -140,11 +136,12 @@ import GHC.Types.Basic
import GHC.Types.Var( Id, CoVar, JoinId,
InId, InVar,
OutId, OutVar,
- idInfo, idDetails, setIdDetails, globaliseId,
+ idInfo, idDetails, setIdDetails, globaliseId, idMult,
isId, isLocalId, isGlobalId, isExportedId,
setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM)
import qualified GHC.Types.Var as Var
+import GHC.Core
import GHC.Core.Type
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.DataCon
@@ -210,9 +207,6 @@ idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
-idMult :: Id -> Mult
-idMult = Var.varMult
-
idScaledType :: Id -> Scaled Type
idScaledType id = Scaled (idMult id) (idType id)
@@ -250,7 +244,7 @@ localiseId id
| assert (isId id) $ isLocalId id && isInternalName name
= id
| otherwise
- = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id)
+ = Var.mkLocalVar (idDetails id) (localiseName name) (Var.idMult id) (idType id) (idInfo id)
where
name = idName id
@@ -544,6 +538,14 @@ isDataConWrapId_maybe id = case Var.idDetails id of
DataConWrapId con -> Just con
_ -> Nothing
+dataConWrapUnfolding_maybe :: Id -> Maybe CoreExpr
+dataConWrapUnfolding_maybe id
+ | DataConWrapId {} <- idDetails id
+ , CoreUnfolding { uf_tmpl = unf } <- realIdUnfolding id
+ = Just unf
+ | otherwise
+ = Nothing
+
isDataConId_maybe :: Id -> Maybe DataCon
isDataConId_maybe id = case Var.idDetails id of
DataConWorkId con -> Just con
=====================================
compiler/GHC/Types/Meta.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.Prelude
import GHC.Serialized ( Serialized )
import GHC.Hs
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
-- | The supported metaprogramming result types
@@ -28,11 +30,42 @@ data MetaRequest
-- | data constructors not exported to ensure correct result type
data MetaResult
- = MetaResE { unMetaResE :: LHsExpr GhcPs }
- | MetaResP { unMetaResP :: LPat GhcPs }
- | MetaResT { unMetaResT :: LHsType GhcPs }
- | MetaResD { unMetaResD :: [LHsDecl GhcPs] }
- | MetaResAW { unMetaResAW :: Serialized }
+ = MetaResE (LHsExpr GhcPs)
+ | MetaResP (LPat GhcPs)
+ | MetaResT (LHsType GhcPs)
+ | MetaResD [LHsDecl GhcPs]
+ | MetaResAW Serialized
+
+instance Outputable MetaResult where
+ ppr (MetaResE e) = text "MetaResE" <> braces (ppr e)
+ ppr (MetaResP p) = text "MetaResP" <> braces (ppr p)
+ ppr (MetaResT t) = text "MetaResT" <> braces (ppr t)
+ ppr (MetaResD d) = text "MetaResD" <> braces (ppr d)
+ ppr (MetaResAW aw) = text "MetaResAW" <> braces (ppr aw)
+
+-- These unMetaResE ext panics will triger if the MetaHook doesn't
+-- take an expression to an expression, pattern to pattern etc.
+--
+-- ToDo: surely this could be expressed in the type system?
+unMetaResE :: MetaResult -> LHsExpr GhcPs
+unMetaResE (MetaResE e) = e
+unMetaResE mr = pprPanic "unMetaResE" (ppr mr)
+
+unMetaResP :: MetaResult -> LPat GhcPs
+unMetaResP (MetaResP p) = p
+unMetaResP mr = pprPanic "unMetaResP" (ppr mr)
+
+unMetaResT :: MetaResult -> LHsType GhcPs
+unMetaResT (MetaResT t) = t
+unMetaResT mr = pprPanic "unMetaResT" (ppr mr)
+
+unMetaResD :: MetaResult -> [LHsDecl GhcPs]
+unMetaResD (MetaResD d) = d
+unMetaResD mr = pprPanic "unMetaResD" (ppr mr)
+
+unMetaResAW :: MetaResult -> Serialized
+unMetaResAW (MetaResAW aw) = aw
+unMetaResAW mr = pprPanic "unMetaResAW" (ppr mr)
type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -45,7 +45,7 @@ module GHC.Types.Var (
-- ** Taking 'Var's apart
varName, varUnique, varType,
- varMult, varMultMaybe,
+ varMultMaybe, idMult,
-- ** Modifying 'Var's
setVarName, setVarUnique, setVarType,
@@ -417,6 +417,10 @@ varMultMaybe :: Id -> Maybe Mult
varMultMaybe (Id { varMult = mult }) = Just mult
varMultMaybe _ = Nothing
+idMult :: HasDebugCallStack => Id -> Mult
+idMult (Id { varMult = mult }) = mult
+idMult non_id = pprPanic "idMult" (ppr non_id)
+
setVarUnique :: Var -> Unique -> Var
setVarUnique var uniq
= var { realUnique = uniq,
=====================================
compiler/GHC/Utils/Panic.hs
=====================================
@@ -23,10 +23,12 @@ module GHC.Utils.Panic
, handleGhcException
-- * Command error throwing patterns
+ , panic
, pprPanic
, panicDoc
, sorryDoc
, pgmErrorDoc
+
-- ** Assertions
, assertPprPanic
, assertPpr
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1103,11 +1103,6 @@ annotations
-}
-isInfixMatch :: Match id body -> Bool
-isInfixMatch match = case m_ctxt match of
- FunRhs {mc_fixity = Infix} -> True
- _ -> False
-
-- | Guarded Right-Hand Sides
--
-- GRHSs are used both for pattern bindings and for Matches
=====================================
compiler/Language/Haskell/Syntax/Pat.hs
=====================================
@@ -28,8 +28,7 @@ module Language.Haskell.Syntax.Pat (
HsRecFields(..), XHsRecFields, HsFieldBind(..), LHsFieldBind,
HsRecField, LHsRecField,
HsRecUpdField, LHsRecUpdField,
- RecFieldsDotDot(..),
- hsRecFields, hsRecFieldSel, hsRecFieldsArgs,
+ RecFieldsDotDot(..)
) where
import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice)
@@ -394,12 +393,3 @@ data HsFieldBind lhs rhs = HsFieldBind {
-- hfbLHS = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id
--
-- See also Note [Disambiguating record updates] in GHC.Rename.Pat.
-
-hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p]
-hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds)
-
-hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]
-hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds)
-
-hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p
-hsRecFieldSel = foExt . unXRec @p . hfbLHS
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -59,8 +59,7 @@ module Language.Haskell.Syntax.Type (
mapHsOuterImplicit,
hsQTvExplicit,
- isHsKindedTyVar,
- hsPatSigType,
+ isHsKindedTyVar
) where
import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice )
@@ -73,6 +72,7 @@ import GHC.Types.Name.Reader ( RdrName )
import GHC.Hs.Doc (LHsDoc)
import GHC.Data.FastString (FastString)
+import GHC.Utils.Panic( panic )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Void
@@ -355,7 +355,8 @@ data LHsQTyVars pass -- See Note [HsType binders]
| XLHsQTyVars !(XXLHsQTyVars pass)
hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass]
-hsQTvExplicit = hsq_explicit
+hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs
+hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit"
------------------------------------------------
-- HsOuterTyVarBndrs
@@ -471,9 +472,6 @@ data HsSigType pass
}
| XHsSigType !(XXHsSigType pass)
-hsPatSigType :: HsPatSigType pass -> LHsType pass
-hsPatSigType = hsps_body
-
{-
Note [forall-or-nothing rule]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -50,6 +50,7 @@ ghcWarningsArgs = do
, package ghc ? pure [ "-Wcpp-undef"
, "-Wincomplete-uni-patterns"
, "-Wincomplete-record-updates"
+ , "-Wno-incomplete-record-selectors"
]
, package ghcPrim ? pure [ "-Wno-trustworthy-safe" ]
, package haddockLibrary ? pure [ "-Wno-unused-imports" ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1580ec44f06f4b1330c8a8d848cef4279e2bb70c...9c4956e817b98a40960adc0a2dd57c4442662401
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1580ec44f06f4b1330c8a8d848cef4279e2bb70c...9c4956e817b98a40960adc0a2dd57c4442662401
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/eab58cea/attachment-0001.html>
More information about the ghc-commits
mailing list