compiler/GHC/Hs/Decls.hs

@@ -10,6 +10,7 @@
                                       -- in module Language.Haskell.Syntax.Extension
 
 {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
+{-# LANGUAGE InstanceSigs #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -125,7 +126,7 @@ import GHC.Types.SrcLoc
 import GHC.Types.SourceText
 import GHC.Core.Type
 import GHC.Types.ForeignCall
-import GHC.Unit.Module.Warnings (WarningTxt(..))
+import GHC.Unit.Module.Warnings
 
 import GHC.Data.Bag
 import GHC.Data.Maybe
@@ -797,8 +798,17 @@ type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
 
 ----------------- Class instances -------------
 
-type instance XCClsInstDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up
-type instance XCClsInstDecl    GhcRn = NoExtField
+type instance XCClsInstDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)
+                                             -- The warning of the deprecated instance
+                                             -- See Note [Implementation of deprecated instances]
+                                             -- in GHC.Tc.Solver.Dict
+                                       , EpAnn [AddEpAnn]
+                                       , AnnSortKey) -- For sorting the additional annotations
+                                        -- TODO:AZ:tidy up
+type instance XCClsInstDecl    GhcRn = Maybe (LWarningTxt GhcRn)
+                                           -- The warning of the deprecated instance
+                                           -- See Note [Implementation of deprecated instances]
+                                           -- in GHC.Tc.Solver.Dict
 type instance XCClsInstDecl    GhcTc = NoExtField
 
 type instance XXClsInstDecl    (GhcPass _) = DataConCantHappen
@@ -815,6 +825,19 @@ type instance XTyFamInstD   GhcTc = NoExtField
 
 type instance XXInstDecl    (GhcPass _) = DataConCantHappen
 
+cidDeprecation :: forall p. IsPass p
+               => ClsInstDecl (GhcPass p)
+               -> Maybe (WarningTxt (GhcPass p))
+cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
+  where
+    decl_deprecation :: GhcPass p  -> ClsInstDecl (GhcPass p)
+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+    decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } )
+      = depr
+    decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })
+      = depr
+    decl_deprecation _ _ = Nothing
+
 instance OutputableBndrId p
        => Outputable (TyFamInstDecl (GhcPass p)) where
   ppr = pprTyFamInstDecl TopLevel
@@ -878,10 +901,10 @@ pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
 
 instance OutputableBndrId p
        => Outputable (ClsInstDecl (GhcPass p)) where
-    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
-                     , cid_sigs = sigs, cid_tyfam_insts = ats
-                     , cid_overlap_mode = mbOverlap
-                     , cid_datafam_insts = adts })
+    ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
+                         , cid_sigs = sigs, cid_tyfam_insts = ats
+                         , cid_overlap_mode = mbOverlap
+                         , cid_datafam_insts = adts })
       | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part
       = top_matter
 
@@ -892,8 +915,9 @@ instance OutputableBndrId p
                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
                pprLHsBindsForUser binds sigs ]
       where
-        top_matter = text "instance" <+> ppOverlapPragma mbOverlap
-                                             <+> ppr inst_ty
+        top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid)
+                                     <+> ppOverlapPragma mbOverlap
+                                     <+> ppr inst_ty
 
 ppDerivStrategy :: OutputableBndrId p
                 => Maybe (LDerivStrategy (GhcPass p)) -> SDoc
@@ -911,6 +935,7 @@ ppOverlapPragma mb =
     Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"
     Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"
     Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"
+    Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet
   where
     maybe_stext NoSourceText     alt = text alt
     maybe_stext (SourceText src) _   = ftext src <+> text "#-}"
@@ -958,19 +983,43 @@ anyLConIsGadt xs = case toList xs of
 ************************************************************************
 -}
 
-type instance XCDerivDecl    (GhcPass _) = EpAnn [AddEpAnn]
+type instance XCDerivDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)
+                                           -- The warning of the deprecated derivation
+                                           -- See Note [Implementation of deprecated instances]
+                                           -- in GHC.Tc.Solver.Dict
+                                     , EpAnn [AddEpAnn] )
+type instance XCDerivDecl    GhcRn = ( Maybe (LWarningTxt GhcRn)
+                                           -- The warning of the deprecated derivation
+                                           -- See Note [Implementation of deprecated instances]
+                                           -- in GHC.Tc.Solver.Dict
+                                     , EpAnn [AddEpAnn] )
+type instance XCDerivDecl    GhcTc = EpAnn [AddEpAnn]
 type instance XXDerivDecl    (GhcPass _) = DataConCantHappen
 
+derivDeprecation :: forall p. IsPass p
+               => DerivDecl (GhcPass p)
+               -> Maybe (WarningTxt (GhcPass p))
+derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
+  where
+    decl_deprecation :: GhcPass p  -> DerivDecl (GhcPass p)
+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+    decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })
+      = depr
+    decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })
+      = depr
+    decl_deprecation _ _ = Nothing
+
 type instance Anno OverlapMode = SrcSpanAnnP
 
 instance OutputableBndrId p
        => Outputable (DerivDecl (GhcPass p)) where
-    ppr (DerivDecl { deriv_type = ty
+    ppr (deriv@DerivDecl { deriv_type = ty
                    , deriv_strategy = ds
                    , deriv_overlap_mode = o })
         = hsep [ text "deriving"
                , ppDerivStrategy ds
                , text "instance"
+               , maybe empty ppr (derivDeprecation deriv)
                , ppOverlapPragma o
                , ppr ty ]
 
@@ -1234,7 +1283,7 @@ instance OutputableBndrId p
               <+> ppr txt
       where
         ppr_category = case txt of
-                         WarningTxt (Just cat) _ _ -> text "[" <> ppr (unLoc cat) <> text "]"
+                         WarningTxt (Just cat) _ _ -> text "in" <+> doubleQuotes (ppr cat)
                          _ -> empty
 
 {-

compiler/GHC/Hs/Expr.hs

@@ -380,6 +380,12 @@ type instance XStatic        GhcTc = (NameSet, Type)
   -- Free variables and type of expression, this is stored for convenience as wiring in
   -- StaticPtr is a bit tricky (see #20150)
 
+type instance XEmbTy         GhcPs = NoExtField
+type instance XEmbTy         GhcRn = NoExtField
+type instance XEmbTy         GhcTc = DataConCantHappen
+  -- A free-standing HsEmbTy is an error.
+  -- Valid usages are immediately desugared into Type.
+
 type instance XPragE         (GhcPass _) = NoExtField
 
 type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL
@@ -702,6 +708,9 @@ ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
 ppr_expr (HsStatic _ e)
   = hsep [text "static", ppr e]
 
+ppr_expr (HsEmbTy _ _ ty)
+  = hsep [text "type", ppr ty]
+
 ppr_expr (XExpr x) = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
   GhcPs -> ppr x
@@ -843,6 +852,7 @@ hsExprNeedsParens prec = go
     go (HsRecSel{})                   = False
     go (HsProjection{})               = True
     go (HsGetField{})                 = False
+    go (HsEmbTy{})                    = prec > topPrec
     go (XExpr x) = case ghcPass @p of
                      GhcTc -> go_x_tc x
                      GhcRn -> go_x_rn x

compiler/GHC/Hs/ImpExp.hs

@@ -38,7 +38,7 @@ import GHC.Hs.Extension
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
-import GHC.Unit.Module.Warnings (WarningTxt)
+import GHC.Unit.Module.Warnings
 
 import Data.Data
 import Data.Maybe
@@ -203,36 +203,36 @@ type instance Anno (IE (GhcPass p)) = SrcSpanAnnA
 -- The additional field of type 'Maybe (WarningTxt pass)' holds information
 -- about export deprecation annotations and is thus set to Nothing when `IE`
 -- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEVar       GhcPs = Maybe (LocatedP (WarningTxt GhcPs))
-type instance XIEVar       GhcRn = Maybe (LocatedP (WarningTxt GhcRn))
+type instance XIEVar       GhcPs = Maybe (LWarningTxt GhcPs)
+type instance XIEVar       GhcRn = Maybe (LWarningTxt GhcRn)
 type instance XIEVar       GhcTc = NoExtField
 
 -- The additional field of type 'Maybe (WarningTxt pass)' holds information
 -- about export deprecation annotations and is thus set to Nothing when `IE`
 -- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEThingAbs  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEThingAbs  GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])
+type instance XIEThingAbs  GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEThingAbs  GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn])
 type instance XIEThingAbs  GhcTc = EpAnn [AddEpAnn]
 
 -- The additional field of type 'Maybe (WarningTxt pass)' holds information
 -- about export deprecation annotations and is thus set to Nothing when `IE`
 -- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEThingAll  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEThingAll  GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])
+type instance XIEThingAll  GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEThingAll  GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn])
 type instance XIEThingAll  GhcTc = EpAnn [AddEpAnn]
 
 -- The additional field of type 'Maybe (WarningTxt pass)' holds information
 -- about export deprecation annotations and is thus set to Nothing when `IE`
 -- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEThingWith GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEThingWith GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])
+type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn])
 type instance XIEThingWith GhcTc = EpAnn [AddEpAnn]
 
 -- The additional field of type 'Maybe (WarningTxt pass)' holds information
 -- about export deprecation annotations and is thus set to Nothing when `IE`
 -- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEModuleContents  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEModuleContents  GhcRn = Maybe (LocatedP (WarningTxt GhcRn))
+type instance XIEModuleContents  GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEModuleContents  GhcRn = Maybe (LWarningTxt GhcRn)
 type instance XIEModuleContents  GhcTc = NoExtField
 
 type instance XIEGroup           (GhcPass _) = NoExtField
@@ -264,7 +264,7 @@ ieNames (IEDocNamed       {})     = []
 ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p))
 ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p)
   where
-    ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+    ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p))
     ie_deprecation GhcPs (IEVar xie _) = xie
     ie_deprecation GhcPs (IEThingAbs (xie, _) _) = xie
     ie_deprecation GhcPs (IEThingAll (xie, _) _) = xie

compiler/GHC/Hs/Pat.hs

@@ -155,6 +155,10 @@ type instance XSigPat GhcPs = EpAnn [AddEpAnn]
 type instance XSigPat GhcRn = NoExtField
 type instance XSigPat GhcTc = Type
 
+type instance XEmbTyPat GhcPs = NoExtField
+type instance XEmbTyPat GhcRn = NoExtField
+type instance XEmbTyPat GhcTc = Type
+
 type instance XXPat GhcPs = DataConCantHappen
 type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)
   -- Original pattern and its desugaring/expansion.
@@ -376,6 +380,7 @@ pprPat (ConPat { pat_con = con
                        , cpt_dicts = dicts
                        , cpt_binds = binds
                        } = ext
+pprPat (EmbTyPat _ toktype tp) = ppr toktype <+> ppr tp
 
 pprPat (XPat ext) = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
@@ -583,6 +588,10 @@ isIrrefutableHsPat is_strict = goL
     -- since we cannot know until the splice is evaluated.
     go (SplicePat {})      = False
 
+    -- The behavior of this case is unimportant, as GHC will throw an error shortly
+    -- after reaching this case for other reasons (see TcRnIllegalTypePattern).
+    go (EmbTyPat {})       = True
+
     go (XPat ext)          = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
       GhcPs -> dataConCantHappen ext
@@ -651,6 +660,7 @@ isBoringHsPat = goL
       NPat {}       -> True
       NPlusKPat {}  -> True
       SplicePat {}  -> False
+      EmbTyPat {}   -> True
       XPat ext ->
         case ghcPass @p of
          GhcRn -> case ext of
@@ -747,6 +757,7 @@ patNeedsParens p = go @p
                          = conPatNeedsParens p ds
     go (SigPat {})       = p >= sigPrec
     go (ViewPat {})      = True
+    go (EmbTyPat {})     = True
     go (XPat ext)        = case ghcPass @q of
 #if __GLASGOW_HASKELL__ < 901
       GhcPs -> dataConCantHappen ext

compiler/GHC/Hs/Syn/Type.hs

@@ -63,6 +63,7 @@ hsPatType (ConPat { pat_con = lcon
 hsPatType (SigPat ty _ _)               = ty
 hsPatType (NPat ty _ _ _)               = ty
 hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
+hsPatType (EmbTyPat ty _ _)             = typeKind ty
 hsPatType (XPat ext) =
   case ext of
     CoPat _ _ ty       -> ty
@@ -142,6 +143,7 @@ hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext
 hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
 hsExprType (HsStatic (_, ty) _s) = ty
 hsExprType (HsPragE _ _ e) = lhsExprType e
+hsExprType (HsEmbTy x _ _) = dataConCantHappen x
 hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
 hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
 hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con

compiler/GHC/Hs/Utils.hs

@@ -1233,11 +1233,15 @@ collect_pat flag pat bndrs = case pat of
   NPat {}               -> bndrs
   NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs
   SigPat _ pat sig      -> case flag of
-    CollVarTyVarBinders -> collect_lpat flag pat bndrs
-                            ++ collectPatSigBndrs sig
-    _                   -> collect_lpat flag pat bndrs
+    CollNoDictBinders   -> collect_lpat flag pat bndrs
+    CollWithDictBinders -> collect_lpat flag pat bndrs
+    CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig
   XPat ext              -> collectXXPat @p flag ext bndrs
   SplicePat ext _       -> collectXSplicePat @p flag ext bndrs
+  EmbTyPat _ _ tp       -> case flag of
+    CollNoDictBinders   -> bndrs
+    CollWithDictBinders -> bndrs
+    CollVarTyVarBinders -> collectTyPatBndrs tp ++ bndrs
   -- See Note [Dictionary binders in ConPatOut]
   ConPat {pat_args=ps}  -> case flag of
     CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)

compiler/GHC/HsToCore/Binds.hs

@@ -41,7 +41,7 @@ import GHC.Hs             -- lots of things
 import GHC.Core           -- lots of things
 import GHC.Core.SimpleOpt    ( simpleOptExpr )
 import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
-import GHC.Core.InstEnv ( Coherence(..) )
+import GHC.Core.InstEnv ( Canonical )
 import GHC.Core.Make
 import GHC.Core.Utils
 import GHC.Core.Opt.Arity     ( etaExpand )
@@ -117,10 +117,54 @@ dsTopLHsBinds binds
     top_level_err bindsType (L loc bind)
       = putSrcSpanDs (locA loc) $
         diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
+{-
+Note [Return non-recursive bindings in dependency order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For recursive bindings, the desugarer has no choice: it returns a single big
+Rec{...} group.
+
+But for /non-recursive/ bindings, the desugarer guarantees to desugar them to
+a sequence of non-recurive Core bindings, in dependency order.
+
+Why is this important?  Partly it saves a bit of work in the first run of the
+ocurrence analyser. But more importantly, for linear types, non-recursive lets
+can be linear whereas recursive-let can't. Since we check the output of the
+desugarer for linearity (see also Note [Linting linearity]), desugaring
+non-recursive lets to recursive lets would break linearity checks. An
+alternative is to refine the typing rule for recursive lets so that we don't
+have to care (see in particular #23218 and #18694), but the outcome of this line
+of work is still unclear. In the meantime, being a little precise in the
+desugarer is cheap. (paragraph written on 2023-06-09)
+
+In dsLHSBinds (and dependencies), a single binding can be desugared to multiple
+bindings. For instance because the source binding has the {-# SPECIALIZE #-}
+pragma. In:
+
+f _ = …
+ where
+  {-# SPECIALIZE g :: F Int -> F Int #-}
+  g :: C a => F a -> F a
+  g _ = …
+
+The g binding desugars to
+
+let {
+  $sg = … } in
+
+  g
+  [RULES: "SPEC g" g @Int $dC = $sg]
+  g = …
+
+In order to avoid generating a letrec that will immediately be reordered, we
+make sure to return the binding in dependency order [$sg, g].
 
+-}
 
 -- | Desugar all other kind of bindings, Ids of strict binds are returned to
 -- later be forced in the binding group body, see Note [Desugar Strict binds]
+--
+-- Invariant: the desugared bindings are returned in dependency order,
+-- see Note [Return non-recursive bindings in dependency order]
 dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
 dsLHsBinds binds
   = do { ds_bs <- mapBagM dsLHsBind binds
@@ -134,6 +178,9 @@ dsLHsBind (L loc bind) = do dflags <- getDynFlags
                             putSrcSpanDs (locA loc) $ dsHsBind dflags bind
 
 -- | Desugar a single binding (or group of recursive binds).
+--
+-- Invariant: the desugared bindings are returned in dependency order,
+-- see Note [Return non-recursive bindings in dependency order]
 dsHsBind :: DynFlags
          -> HsBind GhcTc
          -> DsM ([Id], [(Id,CoreExpr)])
@@ -205,16 +252,15 @@ dsHsBind
                         , abs_exports = exports
                         , abs_ev_binds = ev_binds
                         , abs_binds = binds, abs_sig = has_sig }))
-  = do { ds_binds <- addTyCs FromSource (listToBag dicts) $
+  = dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do
+    { ds_binds <- addTyCs FromSource (listToBag dicts) $
                      dsLHsBinds binds
              -- addTyCs: push type constraints deeper
              --            for inner pattern match check
              -- See Check, Note [Long-distance information]
 
-       ; dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do
-
-       -- dsAbsBinds does the hard work
-       { dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } }
+    -- dsAbsBinds does the hard work
+    ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds (isSingletonBag binds) has_sig }
 
 dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
 
@@ -223,11 +269,12 @@ dsAbsBinds :: DynFlags
            -> [TyVar] -> [EvVar] -> [ABExport]
            -> [CoreBind]                -- Desugared evidence bindings
            -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
+           -> Bool                      -- Single source binding
            -> Bool                      -- Single binding with signature
            -> DsM ([Id], [(Id,CoreExpr)])
 
 dsAbsBinds dflags tyvars dicts exports
-           ds_ev_binds (force_vars, bind_prs) has_sig
+           ds_ev_binds (force_vars, bind_prs) is_singleton has_sig
 
     -- A very important common case: one exported variable
     -- Non-recursive bindings come through this way
@@ -263,14 +310,20 @@ dsAbsBinds dflags tyvars dicts exports
                                        (isDefaultMethod prags)
                                        (dictArity dicts) rhs
 
-       ; return (force_vars', main_bind : fromOL spec_binds) } }
+       ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }
 
     -- Another common case: no tyvars, no dicts
     -- In this case we can have a much simpler desugaring
     --    lcl_id{inl-prag} = rhs  -- Auxiliary binds
     --    gbl_id = lcl_id |> co   -- Main binds
+    --
+    -- See Note [The no-tyvar no-dict case]
   | null tyvars, null dicts
-  = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)
+  = do { let wrap_first_bind f ((main, main_rhs):other_binds) =
+               ((main, f main_rhs):other_binds)
+             wrap_first_bind _ [] = panic "dsAbsBinds received an empty binding list"
+
+             mk_main :: ABExport -> DsM (Id, CoreExpr)
              mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
                           , abe_wrap = wrap })
                      -- No SpecPrags (no dicts)
@@ -278,15 +331,19 @@ dsAbsBinds dflags tyvars dicts exports
                = do { dsHsWrapper wrap $ \core_wrap -> do
                     { return ( gbl_id `setInlinePragma` defaultInlinePragma
                              , core_wrap (Var lcl_id)) } }
-
        ; main_prs <- mapM mk_main exports
-       ; return (force_vars, flattenBinds ds_ev_binds
-                              ++ mk_aux_binds bind_prs ++ main_prs ) }
+       ; let bind_prs' = map mk_aux_bind bind_prs
+             -- When there's a single source binding, we wrap the evidence binding in a
+             -- separate let-rec (DSB1) inside the first desugared binding (DSB2).
+             -- See Note [The no-tyvar no-dict case].
+             final_prs | is_singleton = wrap_first_bind (mkCoreLets ds_ev_binds) bind_prs'
+                       | otherwise = flattenBinds ds_ev_binds ++ bind_prs'
+       ; return (force_vars, final_prs ++ main_prs ) }
 
     -- The general case
     -- See Note [Desugaring AbsBinds]
   | otherwise
-  = do { let aux_binds = Rec (mk_aux_binds bind_prs)
+  = do { let aux_binds = Rec (map mk_aux_bind bind_prs)
                 -- Monomorphic recursion possible, hence Rec
 
              new_force_vars = get_new_force_vars force_vars
@@ -322,7 +379,7 @@ dsAbsBinds dflags tyvars dicts exports
                            -- Kill the INLINE pragma because it applies to
                            -- the user written (local) function.  The global
                            -- Id is just the selector.  Hmm.
-                     ; return ((global', rhs) : fromOL spec_binds) } }
+                     ; return (fromOL spec_binds ++ [(global', rhs)]) } }
 
        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
 
@@ -330,11 +387,11 @@ dsAbsBinds dflags tyvars dicts exports
                 , (poly_tup_id, poly_tup_rhs) :
                    concat export_binds_s) }
   where
-    mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
-    mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs
-                            | (lcl_id, rhs) <- bind_prs
-                            , let lcl_w_inline = lookupVarEnv inline_env lcl_id
-                                                 `orElse` lcl_id ]
+    mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr)
+    mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id
+                                                   `orElse` lcl_id
+                                 in
+                                 makeCorePair dflags lcl_w_inline False 0 rhs
 
     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
                            -- the inline pragma from the source
@@ -473,48 +530,71 @@ So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
 The top-level AbsBinds for $cround has no tyvars or dicts (because the
 instance does not).  But the method is locally overloaded!
 
-Note [Abstracting over tyvars only]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When abstracting over type variable only (not dictionaries), we don't really need to
-built a tuple and select from it, as we do in the general case. Instead we can take
+Note [The no-tyvar no-dict case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are desugaring
+    AbsBinds { tyvars   = []
+             , dicts    = []
+             , exports  = [ ABE f fm, ABE g gm ]
+             , binds    = B
+             , ev_binds = EB }
+That is: no type variables or dictionary abstractions.  Here, `f` and `fm` are
+the polymorphic and monomorphic versions of `f`; in this special case they will
+both have the same type.
+
+Specialising Note [Desugaring AbsBinds] for this case gives the desugaring
+
+    tup = letrec EB' in letrec B' in (fm,gm)
+    f = case tup of { (fm,gm) -> fm }
+    g = case tup of { (fm,gm) -> fm }
+
+where B' is the result of desugaring B. This desugaring is a little silly: we
+don't need the intermediate tuple (contrast with the general case where fm and f
+have different types). So instead, in this case, we desugar to
+
+    EB'; B'; f=fm; g=gm
+
+This is done in the `null tyvars, null dicts` case of `dsAbsBinds`.
 
-        AbsBinds [a,b] [ ([a,b], fg, fl, _),
-                         ([b],   gg, gl, _) ]
-                { fl = e1
-                  gl = e2
-                   h = e3 }
+But there is a wrinkle (DSB1).  If the original binding group was
+/non-recursive/, we want to return a bunch of non-recursive bindings in
+dependency order: see Note [Return non-recursive bindings in dependency order].
 
-and desugar it to
+But there is no guarantee that EB', the desugared evidence bindings, will be
+non-recursive.  Happily, in the non-recursive case, B will have just a single
+binding (f = rhs), so we can wrap EB' around its RHS, thus:
 
-        fg = /\ab. let B in e1
-        gg = /\b. let a = () in let B in S(e2)
-        h  = /\ab. let B in e3
+   fm = letrec EB' in rhs; f = fm
 
-where B is the *non-recursive* binding
-        fl = fg a b
-        gl = gg b
-        h  = h a b    -- See (b); note shadowing!
+There is a sub-wrinkle (DSB2).  If B is a /pattern/ bindings, it will desugar to
+a "main" binding followed by a bunch of selectors. The main binding always
+comes first, so we can pick it out and wrap EB' around its RHS.  For example
 
-Notice (a) g has a different number of type variables to f, so we must
-             use the mkArbitraryType thing to fill in the gaps.
-             We use a type-let to do that.
+    AbsBinds { tyvars   = []
+             , dicts    = []
+             , exports  = [ ABE p pm, ABE q qm ]
+             , binds    = PatBind (pm, Just qm) rhs
+             , ev_binds = EB }
 
-         (b) The local variable h isn't in the exports, and rather than
-             clone a fresh copy we simply replace h by (h a b), where
-             the two h's have different types!  Shadowing happens here,
-             which looks confusing but works fine.
+can desguar to
 
-         (c) The result is *still* quadratic-sized if there are a lot of
-             small bindings.  So if there are more than some small
-             number (10), we filter the binding set B by the free
-             variables of the particular RHS.  Tiresome.
+   pt = let EB' in
+        case rhs of
+          (pm,Just qm) -> (pm,qm)
+   pm = case pt of (pm,qm) -> pm
+   qm = case pt of (pm,qm) -> qm
+
+   p = pm
+   q = qm
+
+The first three bindings come from desugaring the PatBind, and subsequently
+wrapping the RHS of the main binding in EB'.
 
 Why got to this trouble?  It's a common case, and it removes the
 quadratic-sized tuple desugaring.  Less clutter, hopefully faster
 compilation, especially in a case where there are a *lot* of
 bindings.
 
-
 Note [Eta-expanding INLINE things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1153,14 +1233,14 @@ evidence that is used in `e`.
 This question arose when thinking about deep subsumption; see
 https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649).
 
-Note [Desugaring incoherent evidence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the evidence is coherent, we desugar WpEvApp by simply passing
+Note [Desugaring non-canonical evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the evidence is canonical, we desugar WpEvApp by simply passing
 core_tm directly to k:
 
   k core_tm
 
-If the evidence is not coherent, we mark the application with nospec:
+If the evidence is not canonical, we mark the application with nospec:
 
   nospec @(cls => a) k core_tm
 
@@ -1171,14 +1251,14 @@ of the same type (see Note [nospecId magic] in GHC.Types.Id.Make).
 See Note [Coherence and specialisation: overview] for why we shouldn't
 specialise incoherent evidence.
 
-We can find out if a given evidence is coherent or not during the
-desugaring of its WpLet wrapper: an evidence is incoherent if its
+We can find out if a given evidence is canonical or not during the
+desugaring of its WpLet wrapper: an evidence is non-canonical if its
 own resolution was incoherent (see Note [Incoherent instances]), or
-if its definition refers to other incoherent evidence. dsEvBinds is
+if its definition refers to other non-canonical evidence. dsEvBinds is
 the convenient place to compute this, since it already needs to do
 inter-evidence dependency analysis to generate well-scoped
-bindings. We then record this coherence information in the
-dsl_coherence field of DsM's local environment.
+bindings. We then record this specialisability information in the
+dsl_unspecables field of DsM's local environment.
 
 -}
 
@@ -1202,20 +1282,27 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1)) k -- See Note [Desugaring WpFun]
 dsHsWrapper (WpCast co)       k = assert (coercionRole co == Representational) $
                                   k $ \e -> mkCastDs e co
 dsHsWrapper (WpEvApp tm)      k = do { core_tm <- dsEvTerm tm
-                                     ; incoherents <- getIncoherents
+                                     ; unspecables <- getUnspecables
                                      ; let vs = exprFreeVarsList core_tm
-                                           is_incoherent_var v = v `S.member` incoherents
-                                           is_coherent = all (not . is_incoherent_var) vs -- See Note [Desugaring incoherent evidence]
-                                     ; k (\e -> app_ev is_coherent e core_tm) }
+                                           is_unspecable_var v = v `S.member` unspecables
+                                           is_specable = not $ any (is_unspecable_var) vs -- See Note [Desugaring non-canonical evidence]
+                                     ; k (\e -> app_ev is_specable e core_tm) }
   -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
 dsHsWrapper (WpMultCoercion co) k = do { unless (isReflexiveCo co) $
                                            diagnosticDs DsMultiplicityCoercionsNotSupported
                                        ; k $ \e -> e }
 
+-- We are about to construct an evidence application `f dict`.  If the dictionary is
+-- non-specialisable, instead construct
+--     nospec f dict
+-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does.
 app_ev :: Bool -> CoreExpr -> CoreExpr -> CoreExpr
-app_ev is_coherent k core_tm
-    | is_coherent = k `App` core_tm
-    | otherwise   = Var nospecId `App` Type (exprType k) `App` k `App` core_tm
+app_ev is_specable k core_tm
+    | not is_specable
+    = Var nospecId `App` Type (exprType k) `App` k `App` core_tm
+
+    | otherwise
+    = k `App` core_tm
 
 dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
 dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)
@@ -1233,7 +1320,7 @@ dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
 
 --   * Desugars the ev_binds, sorts them into dependency order, and
 --     passes the resulting [CoreBind] to thing_inside
---   * Extends the DsM (dsl_coherence field) with coherence information
+--   * Extends the DsM (dsl_unspecable field) with specialisability information
 --     for each binder in ev_binds, before invoking thing_inside
 dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
 dsEvBinds ev_binds thing_inside
@@ -1241,53 +1328,50 @@ dsEvBinds ev_binds thing_inside
        ; let comps = sort_ev_binds ds_binds
        ; go comps thing_inside }
   where
-    go ::[SCC (Node EvVar (Coherence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a
+    go ::[SCC (Node EvVar (Canonical, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a
     go (comp:comps) thing_inside
-      = do { incoherents <- getIncoherents
-           ; let (core_bind, new_incoherents) = ds_component incoherents comp
-           ; addIncoherents new_incoherents $ go comps $ \ core_binds -> thing_inside (core_bind:core_binds) }
+      = do { unspecables <- getUnspecables
+           ; let (core_bind, new_unspecables) = ds_component unspecables comp
+           ; addUnspecables new_unspecables $ go comps $ \ core_binds -> thing_inside (core_bind:core_binds) }
     go [] thing_inside = thing_inside []
 
-    is_coherent IsCoherent = True
-    is_coherent IsIncoherent = False
-
-    ds_component incoherents (AcyclicSCC node) = (NonRec v rhs, new_incoherents)
+    ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)
       where
-        ((v, rhs), (this_coherence, deps)) = unpack_node node
-        transitively_incoherent = not (is_coherent this_coherence) || any is_incoherent deps
-        is_incoherent dep = dep `S.member` incoherents
-        new_incoherents
-            | transitively_incoherent = S.singleton v
+        ((v, rhs), (this_canonical, deps)) = unpack_node node
+        transitively_unspecable = not this_canonical || any is_unspecable deps
+        is_unspecable dep = dep `S.member` unspecables
+        new_unspecables
+            | transitively_unspecable = S.singleton v
             | otherwise = mempty
-    ds_component incoherents (CyclicSCC nodes) = (Rec pairs, new_incoherents)
+    ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
       where
-        (pairs, direct_coherence) = unzip $ map unpack_node nodes
+        (pairs, direct_canonicity) = unzip $ map unpack_node nodes
 
-        is_incoherent_remote dep = dep `S.member` incoherents
-        transitively_incoherent = or [ not (is_coherent this_coherence) || any is_incoherent_remote deps | (this_coherence, deps) <- direct_coherence ]
-            -- Bindings from a given SCC are transitively coherent if
-            -- all are coherent and all their remote dependencies are
-            -- also coherent; see Note [Desugaring incoherent evidence]
+        is_unspecable_remote dep = dep `S.member` unspecables
+        transitively_unspecable = or [ not this_canonical || any is_unspecable_remote deps | (this_canonical, deps) <- direct_canonicity ]
+            -- Bindings from a given SCC are transitively specialisable if
+            -- all are specialisable and all their remote dependencies are
+            -- also specialisable; see Note [Desugaring non-canonical evidence]
 
-        new_incoherents
-            | transitively_incoherent = S.fromList [ v | (v, _) <- pairs]
+        new_unspecables
+            | transitively_unspecable = S.fromList [ v | (v, _) <- pairs]
             | otherwise = mempty
 
-    unpack_node DigraphNode { node_key = v, node_payload = (coherence, rhs), node_dependencies = deps } = ((v, rhs), (coherence, deps))
+    unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps } = ((v, rhs), (canonical, deps))
 
-sort_ev_binds :: Bag (Id, Coherence, CoreExpr) -> [SCC (Node EvVar (Coherence, CoreExpr))]
+sort_ev_binds :: Bag (Id, Canonical, CoreExpr) -> [SCC (Node EvVar (Canonical, CoreExpr))]
 -- We do SCC analysis of the evidence bindings, /after/ desugaring
 -- them. This is convenient: it means we can use the GHC.Core
 -- free-variable functions rather than having to do accurate free vars
 -- for EvTerm.
 sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges
   where
-    edges :: [ Node EvVar (Coherence, CoreExpr) ]
+    edges :: [ Node EvVar (Canonical, CoreExpr) ]
     edges = foldr ((:) . mk_node) [] ds_binds
 
-    mk_node :: (Id, Coherence, CoreExpr) -> Node EvVar (Coherence, CoreExpr)
-    mk_node (var, coherence, rhs)
-      = DigraphNode { node_payload = (coherence, rhs)
+    mk_node :: (Id, Canonical, CoreExpr) -> Node EvVar (Canonical, CoreExpr)
+    mk_node (var, canonical, rhs)
+      = DigraphNode { node_payload = (canonical, rhs)
                     , node_key = var
                     , node_dependencies = nonDetEltsUniqSet $
                                           exprFreeVars rhs `unionVarSet`
@@ -1296,13 +1380,13 @@ sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges
       -- is still deterministic even if the edges are in nondeterministic order
       -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
 
-dsEvBind :: EvBind -> DsM (Id, Coherence, CoreExpr)
+dsEvBind :: EvBind -> DsM (Id, Canonical, CoreExpr)
 dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do
     e <- dsEvTerm r
-    let coherence = case info of
-            EvBindGiven{} -> IsCoherent
-            EvBindWanted{ ebi_coherence = coherence } -> coherence
-    return (v, coherence, e)
+    let canonical = case info of
+            EvBindGiven{} -> True
+            EvBindWanted{ ebi_canonical = canonical } -> canonical
+    return (v, canonical, e)
 
 
 {-**********************************************************************

compiler/GHC/HsToCore/Errors/Ppr.hs

@@ -207,6 +207,10 @@ instance Diagnostic DsMessage where
                           <+> text "for"<+> quotes (ppr lhs_id)
                           <+> text "might fire first")
                 ]
+    DsIncompleteRecordSelector name cons_wo_field not_full_examples -> mkSimpleDecorated $
+      text "The application of the record field" <+> quotes (ppr name)
+      <+> text "may fail for the following constructors:"
+      <+> vcat (map ppr cons_wo_field ++ [text "..." | not_full_examples])
 
   diagnosticReason = \case
     DsUnknownMessage m          -> diagnosticReason m
@@ -237,6 +241,7 @@ instance Diagnostic DsMessage where
     DsRecBindsNotAllowedForUnliftedTys{}        -> ErrorWithoutFlag
     DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing
     DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing
+    DsIncompleteRecordSelector{}                -> WarningWithFlag Opt_WarnIncompleteRecordSelectors
 
   diagnosticHints = \case
     DsUnknownMessage m          -> diagnosticHints m
@@ -273,6 +278,7 @@ instance Diagnostic DsMessage where
     DsRecBindsNotAllowedForUnliftedTys{}        -> noHints
     DsRuleMightInlineFirst _ lhs_id rule_act    -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]
     DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]
+    DsIncompleteRecordSelector{}                -> noHints
 
   diagnosticCode = constructorCode
 

compiler/GHC/HsToCore/Errors/Types.hs

@@ -8,6 +8,7 @@ import GHC.Prelude
 
 import GHC.Core (CoreRule, CoreExpr, RuleName)
 import GHC.Core.DataCon
+import GHC.Core.ConLike
 import GHC.Core.Type
 import GHC.Driver.DynFlags (DynFlags, xopt)
 import GHC.Driver.Flags (WarningFlag)
@@ -147,6 +148,23 @@ data DsMessage
                                 !RuleName -- the \"bad\" rule
                                 !Var
 
+  {-| DsIncompleteRecordSelector is a warning triggered when we are not certain whether
+      a record selector application will be successful. Currently, this means that
+      the warning is triggered when there is a record selector of a data type that
+      does not have that field in all its constructors.
+
+      Example(s):
+      data T = T1 | T2 {x :: Bool}
+      f :: T -> Bool
+      f a = x a
+
+     Test cases:
+       DsIncompleteRecSel1
+       DsIncompleteRecSel2
+       DsIncompleteRecSel3
+  -}
+  | DsIncompleteRecordSelector !Name ![ConLike] !Bool
+
   deriving Generic
 
 -- The positional number of the argument for an expression (first, second, third, etc)

compiler/GHC/HsToCore/Expr.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
+{-# LANGUAGE LambdaCase #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -31,7 +32,7 @@ import GHC.HsToCore.Monad
 import GHC.HsToCore.Pmc
 import GHC.HsToCore.Errors.Types
 import GHC.Types.SourceText
-import GHC.Types.Name
+import GHC.Types.Name hiding (varName)
 import GHC.Core.FamInstEnv( topNormaliseType )
 import GHC.HsToCore.Quote
 import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
@@ -51,6 +52,7 @@ import GHC.Core.Make
 import GHC.Driver.Session
 import GHC.Types.CostCentre
 import GHC.Types.Id
+import GHC.Types.Id.Info
 import GHC.Types.Id.Make
 import GHC.Unit.Module
 import GHC.Core.ConLike
@@ -67,6 +69,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Core.PatSyn
 import Control.Monad
+import GHC.Types.Error
 
 {-
 ************************************************************************
@@ -160,17 +163,22 @@ ds_val_bind (is_rec, binds) body
           -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
           case prs of
             [] -> return body
-            _  -> return (Let (Rec prs) body') }
-        -- Use a Rec regardless of is_rec.
-        -- Why? Because it allows the binds to be all
-        -- mixed up, which is what happens in one rare case
-        -- Namely, for an AbsBind with no tyvars and no dicts,
-        --         but which does have dictionary bindings.
-        -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
-        -- It turned out that wrapping a Rec here was the easiest solution
-        --
-        -- NB The previous case dealt with unlifted bindings, so we
-        --    only have to deal with lifted ones now; so Rec is ok
+            _  -> return (mkLets (mk_binds is_rec prs) body') }
+            -- We can make a non-recursive let because we make sure to return
+            -- the bindings in dependency order in dsLHsBinds,
+            -- see Note [Return non-recursive bindings in dependency order] in
+            -- GHC.HsToCore.Binds
+
+-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for
+-- instance.
+--
+--   * @'mk_binds' 'Recursive' binds@ makes a single mutually-recursive
+--     bindings with all the rhs/lhs pairs in @binds@
+--   * @'mk_binds' 'NonRecursive' binds@ makes one non-recursive binding
+--     for each rhs/lhs pairs in @binds@
+mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
+mk_binds Recursive binds = [Rec binds]
+mk_binds NonRecursive binds = map (uncurry NonRec) binds
 
 ------------------
 dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
@@ -203,11 +211,8 @@ dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss
         -- ==> case rhs of C x# y# -> body
     do { match_nablas <- pmcGRHSs PatBindGuards grhss
        ; rhs          <- dsGuarded grhss ty match_nablas
-       ; let upat = unLoc pat
-             eqn = EqnInfo { eqn_pats = [upat],
-                             eqn_orig = FromSource,
-                             eqn_rhs = cantFailMatchResult body }
-       ; var    <- selectMatchVar ManyTy upat
+       ; let eqn = EqnMatch { eqn_pat = pat, eqn_rest = EqnDone (cantFailMatchResult body) }
+       ; var    <- selectMatchVar ManyTy (unLoc pat)
                     -- `var` will end up in a let binder, so the multiplicity
                     -- doesn't matter.
        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
@@ -230,7 +235,38 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e
 -- | Desugar a typechecked expression.
 dsExpr :: HsExpr GhcTc -> DsM CoreExpr
 dsExpr (HsVar    _ (L _ id))           = dsHsVar id
-dsExpr (HsRecSel _ (FieldOcc id _))    = dsHsVar id
+
+{- Record selectors are warned about if they are not
+present in all of the parent data type's constructor,
+or always in case of pattern synonym record selectors
+(regulated by a flag). However, this only produces
+a warning if it's not a part of a record selector
+application. For example:
+
+        data T = T1 | T2 {s :: Bool}
+        f x = s x -- the warning from this case will be supressed
+
+See the `HsApp` case for where it is filtered out
+-}
+dsExpr (HsRecSel _ (FieldOcc id _))
+  = do { let name = getName id
+             RecSelId {sel_cons = (_, cons_wo_field)}
+                  = idDetails id
+       ; cons_trimmed <- trim_cons cons_wo_field
+       ; unless (null cons_wo_field) $ diagnosticDs
+             $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
+                 -- This only produces a warning if it's not a part of a
+                 -- record selector application (e.g. `s a` where `s` is a selector)
+                 -- See the `HsApp` case for where it is filtered out
+       ; dsHsVar id }
+  where
+    trim_cons :: [ConLike] -> DsM [ConLike]
+    trim_cons cons_wo_field = do
+      dflags <- getDynFlags
+      let maxConstructors = maxUncoveredPatterns dflags
+      return $ take maxConstructors cons_wo_field
+
+
 dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref
         -- See Note [Holes] in GHC.Tc.Types.Constraint
 
@@ -297,9 +333,27 @@ dsExpr (HsLamCase _ lc_variant matches)
   = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches
 
 dsExpr e@(HsApp _ fun arg)
-  = do { fun' <- dsLExpr fun
+         -- We want to have a special case that uses the PMC information to filter
+         -- out some of the incomplete record selectors warnings and not trigger
+         -- the warning emitted during the desugaring of dsExpr(HsRecSel)
+         -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+  = do { (msgs, fun') <- captureMessagesDs $ dsLExpr fun
+             -- Make sure to filter out the generic incomplete record selector warning
+             -- if it's a raw record selector
        ; arg' <- dsLExpr arg
+       ; case getIdFromTrivialExpr_maybe fun' of
+           Just fun_id | isRecordSelector fun_id
+             -> do { let msgs' = filterMessages is_incomplete_rec_sel_msg msgs
+                   ; addMessagesDs msgs'
+                   ; pmcRecSel fun_id arg' }
+           _ -> addMessagesDs msgs
        ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
+  where
+    is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool
+    is_incomplete_rec_sel_msg (MsgEnvelope {errMsgDiagnostic = DsIncompleteRecordSelector{}})
+                                = False
+    is_incomplete_rec_sel_msg _ = True
+
 
 dsExpr e@(HsAppType {}) = dsHsWrapped e
 
@@ -365,6 +419,8 @@ dsExpr (ExplicitSum types alt arity expr)
 dsExpr (HsPragE _ prag expr) =
   ds_prag_expr prag expr
 
+dsExpr (HsEmbTy x _ _) = dataConCantHappen x
+
 dsExpr (HsCase ctxt discrim matches)
   = do { core_discrim <- dsLExpr discrim
        ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches

compiler/GHC/HsToCore/Foreign/JavaScript.hs

@@ -58,7 +58,6 @@ import GHC.Builtin.Types.Prim
 import GHC.Builtin.Names
 
 import GHC.Data.FastString
-import GHC.Data.Pair
 import GHC.Data.Maybe
 
 import GHC.Utils.Outputable
@@ -83,7 +82,7 @@ dsJsFExport
 
 dsJsFExport fn_id co ext_name cconv isDyn = do
     let
-       ty                              = pSnd $ coercionKind co
+       ty                              = coercionRKind co
        (_tvs,sans_foralls)             = tcSplitForAllTyVars ty
        (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
        -- We must use tcSplits here, because we want to see
@@ -242,7 +241,7 @@ dsJsImport
   -> Maybe Header
   -> DsM ([Binding], CHeader, CStub)
 dsJsImport id co (CLabel cid) cconv _ _ = do
-   let ty = pFst $ coercionKind co
+   let ty = coercionLKind co
        fod = case tyConAppTyCon_maybe (dropForAlls ty) of
              Just tycon
               | tyConUnique tycon == funPtrTyConKey ->
@@ -272,7 +271,7 @@ dsJsFExportDynamic :: Id
                  -> DsM ([Binding], CHeader, CStub)
 dsJsFExportDynamic id co0 cconv = do
     let
-      ty                            = pFst (coercionKind co0)
+      ty                            = coercionLKind co0
       (tvs,sans_foralls)            = tcSplitForAllTyVars ty
       ([Scaled arg_mult arg_ty], fn_res_ty)  = tcSplitFunTys sans_foralls
       (io_tc, res_ty)               = expectJust "dsJsFExportDynamic: IO type expected"
@@ -342,7 +341,7 @@ dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
         -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
 dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do
     let
-        ty                   = pFst $ coercionKind co
+        ty                   = coercionLKind co
         (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
         (arg_tys, io_res_ty) = tcSplitFunTys rho
 

compiler/GHC/HsToCore/Match.hs

@@ -29,8 +29,12 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
 
 import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
 
-import GHC.Types.Basic ( Origin(..), isGenerated, requiresPMC )
+import GHC.Types.Basic ( Origin(..), requiresPMC )
 import GHC.Types.SourceText
+    ( FractionalLit,
+      IntegralLit(il_value),
+      negateFractionalLit,
+      integralFractionalLit )
 import GHC.Driver.DynFlags
 import GHC.Hs
 import GHC.Hs.Syn.Type
@@ -193,13 +197,9 @@ match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with
 
 match [] ty eqns
   = assertPpr (not (null eqns)) (ppr ty) $
-    return (foldr1 combineMatchResults match_results)
-  where
-    match_results = [ assert (null (eqn_pats eqn)) $
-                      eqn_rhs eqn
-                    | eqn <- eqns ]
+    combineEqnRhss (NEL.fromList eqns)
 
-match (v:vs) ty eqns    -- Eqns *can* be empty
+match (v:vs) ty eqns    -- Eqns can be empty, but each equation is nonempty
   = assertPpr (all (isInternalName . idName) vars) (ppr vars) $
     do  { dflags <- getDynFlags
         ; let platform = targetPlatform dflags
@@ -222,12 +222,11 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
     dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
     dropGroup = fmap snd
 
-    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
-    -- Result list of [MatchResult CoreExpr] is always non-empty
+    match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr))
     match_groups [] = matchEmpty v ty
     match_groups (g:gs) = mapM match_group $ g :| gs
 
-    match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
+    match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr)
     match_group eqns@((group,_) :| _)
         = case group of
             PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
@@ -267,20 +266,20 @@ matchEmpty var res_ty
     mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty
                                       [Alt DEFAULT [] fail]
 
-matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
 -- Real true variables, just like in matchVar, SLPJ p 94
 -- No binding to do: they'll all be wildcards by now (done in tidy)
 matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
 
-matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
 matchBangs (var :| vars) ty eqns
   = do  { match_result <- match (var:vars) ty $ NEL.toList $
             decomposeFirstPat getBangPat <$> eqns
         ; return (mkEvalMatchResult var ty match_result) }
 
-matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
 -- Apply the coercion to the match variable and then match that
-matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
+matchCoercion (var :| vars) ty eqns@(eqn1 :| _)
   = do  { let XPat (CoPat co pat _) = firstPat eqn1
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var (idMult var) pat_ty'
@@ -290,9 +289,9 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
         { let bind = NonRec var' (core_wrap (Var var))
         ; return (mkCoLetMatchResult bind match_result) } }
 
-matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
 -- Apply the view function to the match variable and then match that
-matchView (var :| vars) ty (eqns@(eqn1 :| _))
+matchView (var :| vars) ty eqns@(eqn1 :| _)
   = do  { -- we could pass in the expr from the PgView,
          -- but this needs to extract the pat anyway
          -- to figure out the type of the fresh variable
@@ -309,10 +308,9 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
                     match_result) }
 
 -- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
-        = eqn { eqn_pats = extractpat pat : pats}
-decomposeFirstPat _ _ = panic "decomposeFirstPat"
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE
+decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat}
+decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat"
 
 getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
 getCoPat (XPat (CoPat _ pat _)) = pat
@@ -405,15 +403,14 @@ tidyEqnInfo :: Id -> EquationInfo
         -- POST CONDITION: head pattern in the EqnInfo is
         --      one of these for which patGroup is defined.
 
-tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
-  = panic "tidyEqnInfo"
+tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
 
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
-  = do { (wrap, pat') <- tidy1 v orig pat
-       ; return (wrap, eqn { eqn_pats = pat' : pats }) }
+tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do
+  (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat
+  return (wrap, eqn{eqn_pat = L loc pat' })
 
 tidy1 :: Id                  -- The Id being scrutinised
-      -> Origin              -- Was this a pattern the user wrote?
+      -> Bool                -- `True` if the pattern was generated, `False` if it was user-written
       -> Pat GhcTc           -- The pattern against which it is to be matched
       -> DsM (DsWrapper,     -- Extra bindings to do before the match
               Pat GhcTc)     -- Equivalent pattern
@@ -424,10 +421,10 @@ tidy1 :: Id                  -- The Id being scrutinised
 -- It eliminates many pattern forms (as-patterns, variable patterns,
 -- list patterns, etc) and returns any created bindings in the wrapper.
 
-tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat)
-tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
+tidy1 v g (ParPat _ _ pat _)  = tidy1 v g (unLoc pat)
+tidy1 v g (SigPat _ pat _)    = tidy1 v g (unLoc pat)
 tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
+tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p
 
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
@@ -436,8 +433,8 @@ tidy1 v _ (VarPat _ (L _ var))
 
         -- case v of { x@p -> mr[] }
         -- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (L _ var) _ pat)
-  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)
+tidy1 v g (AsPat _ (L _ var) _ pat)
+  = do  { (wrap, pat') <- tidy1 v g (unLoc pat)
         ; return (wrapBind var v . wrap, pat') }
 
 {- now, here we handle lazy patterns:
@@ -489,22 +486,22 @@ tidy1 _ _ (SumPat tys pat alt arity)
                  -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
 
 -- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
-  = do { unless (isGenerated o) $
+tidy1 _ g (LitPat _ lit)
+  = do { unless g $
            warnAboutOverflowedLit lit
        ; return (idDsWrapper, tidyLitPat lit) }
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
-  = do { unless (isGenerated o) $
+tidy1 _ g (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
+  = do { unless g $
            let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
                     | otherwise = lit
            in warnAboutOverflowedOverLit lit'
        ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
 
 -- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
-  = do { unless (isGenerated o) $ do
+tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
+  = do { unless g $ do
            warnAboutOverflowedOverLit lit1
            warnAboutOverflowedOverLit lit2
        ; return (idDsWrapper, n) }
@@ -514,28 +511,28 @@ tidy1 _ _ non_interesting_pat
   = return (idDsWrapper, non_interesting_pat)
 
 --------------------
-tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
+tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc
               -> DsM (DsWrapper, Pat GhcTc)
 
 -- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
+tidy_bang_pat v g _ (ParPat _ _ (L l p) _) = tidy_bang_pat v g l p
+tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p
 
 -- Push the bang-pattern inwards, in the hope that
 -- it may disappear next time
-tidy_bang_pat v o l (AsPat x v' at p)
-  = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (XPat (CoPat w p t))
-  = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
+tidy_bang_pat v g l (AsPat x v' at p)
+  = tidy1 v g (AsPat x v' at (L l (BangPat noExtField p)))
+tidy_bang_pat v g l (XPat (CoPat w p t))
+  = tidy1 v g (XPat $ CoPat w (BangPat noExtField (L l p)) t)
 
 -- Discard bang around strict pattern
-tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p
-tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p
-tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p
-tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
+tidy_bang_pat v g _ p@(LitPat {})    = tidy1 v g p
+tidy_bang_pat v g _ p@(ListPat {})   = tidy1 v g p
+tidy_bang_pat v g _ p@(TuplePat {})  = tidy1 v g p
+tidy_bang_pat v g _ p@(SumPat {})    = tidy1 v g p
 
 -- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
+tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc)
                               , pat_args = args
                               , pat_con_ext = ConPatTc
                                 { cpt_arg_tys = arg_tys
@@ -544,8 +541,8 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
   -- Newtypes: push bang inwards (#9844)
   =
     if isNewTyCon (dataConTyCon dc)
-      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
-      else tidy1 v o p  -- Data types: discard the bang
+      then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
+      else tidy1 v g p  -- Data types: discard the bang
     where
       (ty:_) = dataConInstArgTys dc arg_tys
 
@@ -808,16 +805,14 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
     mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
     mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
       = do { dflags <- getDynFlags
-           ; let upats = map (unLoc . decideBangHood dflags) pats
+           ; let upats = map (decideBangHood dflags) pats
            -- pat_nablas is the covered set *after* matching the pattern, but
            -- before any of the GRHSs. We extend the environment with pat_nablas
            -- (via updPmNablas) so that the where-clause of 'grhss' can profit
            -- from that knowledge (#18533)
            ; match_result <- updPmNablas pat_nablas $
                              dsGRHSs ctxt grhss rhs_ty rhss_nablas
-           ; return EqnInfo { eqn_pats = upats
-                            , eqn_orig = FromSource
-                            , eqn_rhs  = match_result } }
+           ; return $ mkEqnInfo upats match_result }
 
     discard_warnings_if_skip_pmc orig =
       if requiresPMC orig
@@ -958,10 +953,9 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
               pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
          else getLdiNablas
 
-       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
-                                , eqn_orig = FromSource
-                                , eqn_rhs  =
-               updPmNablasMatchResult ldi_nablas match_result }
+       ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat
+                                 , eqn_rest =
+          EqnDone $ updPmNablasMatchResult ldi_nablas match_result }
                -- See Note [Long-distance information in do notation]
                -- in GHC.HsToCore.Expr.
 
@@ -999,6 +993,13 @@ data PatGroup
                         -- the LHsExpr is the expression e
            Type         -- the Type is the type of p (equivalently, the result type of e)
 
+instance Show PatGroup where
+  show PgAny = "PgAny"
+  show (PgCon _) = "PgCon"
+  show (PgLit _) = "PgLit"
+  show (PgView _ _) = "PgView"
+  show _ = "PgOther"
+
 {- Note [Don't use Literal for PgN]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Previously we had, as PatGroup constructors
@@ -1019,7 +1020,7 @@ the PgN constructor as a FractionalLit if numeric, and add a PgOverStr construct
 for overloaded strings.
 -}
 
-groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
+groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
 -- If the result is of form [g1, g2, g3],
 -- (a) all the (pg,eq) pairs in g1 have the same pg
 -- (b) none of the gi are empty
@@ -1163,8 +1164,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
     -- the fixities have been straightened out by now, so it's safe
     -- to ignore them?
-    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
-        lexp l l' && lexp o o' && lexp ri ri'
+    exp (OpApp _ l g ri) (OpApp _ l' o' ri') =
+        lexp l l' && lexp g o' && lexp ri ri'
     exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
     exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
@@ -1265,6 +1266,7 @@ patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
 patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
 patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit)
+patGroup _ EmbTyPat{} = PgAny
 patGroup platform (XPat ext) = case ext of
   CoPat _ p _      -> PgCo (hsPatType p) -- Type of innelexp pattern
   ExpansionPat _ p -> patGroup platform p

compiler/GHC/HsToCore/Match/Constructor.hs

@@ -21,7 +21,6 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match )
 import GHC.Hs
 import GHC.HsToCore.Binds
 import GHC.Core.ConLike
-import GHC.Types.Basic
 import GHC.Tc.Utils.TcType
 import GHC.Core.Multiplicity
 import GHC.HsToCore.Monad
@@ -95,7 +94,7 @@ have-we-used-all-the-constructors? question; the local function
 
 matchConFamily :: NonEmpty Id
                -> Type
-               -> NonEmpty (NonEmpty EquationInfo)
+               -> NonEmpty (NonEmpty EquationInfoNE)
                -> DsM (MatchResult CoreExpr)
 -- Each group of eqns is for a single constructor
 matchConFamily (var :| vars) ty groups
@@ -114,7 +113,7 @@ matchConFamily (var :| vars) ty groups
 
 matchPatSyn :: NonEmpty Id
             -> Type
-            -> NonEmpty EquationInfo
+            -> NonEmpty EquationInfoNE
             -> DsM (MatchResult CoreExpr)
 matchPatSyn (var :| vars) ty eqns
   = do let mult = idMult var
@@ -130,7 +129,7 @@ type ConArgPats = HsConPatDetails GhcTc
 matchOneConLike :: [Id]
                 -> Type
                 -> Mult
-                -> NonEmpty EquationInfo
+                -> NonEmpty EquationInfoNE
                 -> DsM (CaseAlt ConLike)
 matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single constructor
   = do  { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $
@@ -144,7 +143,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
         -- and returns the types of the *value* args, which is what we want
 
               match_group :: [Id]
-                          -> NonEmpty (ConArgPats, EquationInfo)
+                          -> NonEmpty (ConArgPats, EquationInfoNE)
                           -> DsM (MatchResult CoreExpr)
               -- All members of the group have compatible ConArgPats
               match_group arg_vars arg_eqn_prs
@@ -154,24 +153,21 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
                      ; return $ foldr1 (.) wraps <$> match_result
                      }
 
-              shift (_, eqn@(EqnInfo
-                             { eqn_pats = ConPat
-                               { pat_args = args
-                               , pat_con_ext = ConPatTc
-                                 { cpt_tvs = tvs
-                                 , cpt_dicts = ds
-                                 , cpt_binds = bind
-                                 }
-                               } : pats
-                             }))
+              shift (_, EqnMatch {
+                      eqn_pat = L _ (ConPat
+                                    { pat_args = args
+                                    , pat_con_ext = ConPatTc
+                                      { cpt_tvs = tvs
+                                      , cpt_dicts = ds
+                                      , cpt_binds = bind }})
+                    , eqn_rest = rest })
                 = do dsTcEvBinds bind $ \ds_bind ->
                        return ( wrapBinds (tvs `zip` tvs1)
                               . wrapBinds (ds  `zip` dicts1)
                               . mkCoreLets ds_bind
-                              , eqn { eqn_orig = Generated SkipPmc
-                                    , eqn_pats = conArgPats val_arg_tys args ++ pats }
+                              , prependPats (conArgPats val_arg_tys args) rest
                               )
-              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+              shift (_, eqn) = pprPanic "matchOneCon/shift" (ppr eqn)
         ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys
             -- The 'val_arg_tys' are taken from the data type definition, they
             -- do not take into account the context multiplicity, therefore we
@@ -185,7 +181,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
                 -- suggestions for the new variables
 
         -- Divide into sub-groups; see Note [Record patterns]
-        ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo))
+        ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE))
               groups = NE.groupBy1 compatible_pats
                      $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
 
@@ -257,14 +253,14 @@ conArgPats :: [Scaled Type]-- Instantiated argument types
                           -- Used only to fill in the types of WildPats, which
                           -- are probably never looked at anyway
            -> ConArgPats
-           -> [Pat GhcTc]
-conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps
-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+           -> [LPat GhcTc]
+conArgPats _arg_tys (PrefixCon _ ps) = ps
+conArgPats _arg_tys (InfixCon p1 p2) = [p1, p2]
 conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
-  | null rpats = map WildPat (map scaledThing arg_tys)
+  | null rpats = map (noLocA . WildPat . scaledThing) arg_tys
         -- Important special case for C {}, which can be used for a
         -- datacon that isn't declared to have fields at all
-  | otherwise  = map (unLoc . hfbRHS . unLoc) rpats
+  | otherwise  = map (hfbRHS . unLoc) rpats
 
 {-
 Note [Record patterns]

compiler/GHC/HsToCore/Match/Literal.hs

@@ -607,7 +607,7 @@ tidyNPat over_lit mb_neg eq outer_ty
 
 matchLiterals :: NonEmpty Id
               -> Type -- ^ Type of the whole case expression
-              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
+              -> NonEmpty (NonEmpty EquationInfoNE) -- ^ All PgLits
               -> DsM (MatchResult CoreExpr)
 
 matchLiterals (var :| vars) ty sub_groups
@@ -625,11 +625,11 @@ matchLiterals (var :| vars) ty sub_groups
             return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
         }
   where
-    match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
-    match_group eqns@(firstEqn :| _)
+    match_group :: NonEmpty EquationInfoNE -> DsM (Literal, MatchResult CoreExpr)
+    match_group eqns
         = do { dflags <- getDynFlags
              ; let platform = targetPlatform dflags
-             ; let LitPat _ hs_lit = firstPat firstEqn
+             ; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns
              ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
              ; return (hsLitKey platform hs_lit, match_result) }
 
@@ -682,7 +682,7 @@ hsLitKey _        l                   = pprPanic "hsLitKey" (ppr l)
 ************************************************************************
 -}
 
-matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
 matchNPats (var :| vars) ty (eqn1 :| eqns)    -- All for the same literal
   = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
@@ -711,7 +711,7 @@ We generate:
 \end{verbatim}
 -}
 
-matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
 -- All NPlusKPats, for the *same* literal k
 matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
   = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
@@ -727,7 +727,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
                    fmap (foldr1 (.) wraps)                      $
                    match_result) }
   where
-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
-        = (wrapBind n n1, eqn { eqn_pats = pats })
+    shift n1 (EqnMatch { eqn_pat = L _ (NPlusKPat _ (L _ n) _ _ _ _), eqn_rest = rest })
+        = (wrapBind n n1, rest)
         -- The wrapBind is a no-op for the first equation
     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)

compiler/GHC/HsToCore/Monad.hs

@@ -37,7 +37,7 @@ module GHC.HsToCore.Monad (
         getPmNablas, updPmNablas,
 
         -- Tracking evidence variable coherence
-        addIncoherents, getIncoherents,
+        addUnspecables, getUnspecables,
 
         -- Get COMPLETE sets of a TyCon
         dsGetCompleteMatches,
@@ -45,10 +45,12 @@ module GHC.HsToCore.Monad (
         -- Warnings and errors
         DsWarning, diagnosticDs, errDsCoreExpr,
         failWithDs, failDs, discardWarningsDs,
+        addMessagesDs, captureMessagesDs,
 
         -- Data types
         DsMatchContext(..),
-        EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
+        EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult,
+        MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
 
         -- Trace injection
         pprRuntimeTrace
@@ -91,7 +93,6 @@ import GHC.Unit.Module
 import GHC.Unit.Module.ModGuts
 
 import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
 import GHC.Types.SourceFile
 import GHC.Types.Id
 import GHC.Types.Var (EvId)
@@ -131,27 +132,42 @@ instance Outputable DsMatchContext where
   ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
 
 data EquationInfo
-  = EqnInfo { eqn_pats :: [Pat GhcTc]
-              -- ^ The patterns for an equation
-              --
-              -- NB: We have /already/ applied 'decideBangHood' to
-              -- these patterns.  See Note [decideBangHood] in "GHC.HsToCore.Utils"
-
-            , eqn_orig :: Origin
-              -- ^ Was this equation present in the user source?
-              --
-              -- This helps us avoid warnings on patterns that GHC elaborated.
-              --
-              -- For instance, the pattern @-1 :: Word@ gets desugared into
-              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
-              -- literal for /both/ of these cases.
-
-            , eqn_rhs  :: MatchResult CoreExpr
-              -- ^ What to do after match
-            }
+  = EqnMatch  { eqn_pat :: LPat GhcTc
+                -- ^ The first pattern of the equation
+                --
+                -- NB: The location info is used to determine whether the
+                -- pattern is generated or not.
+                -- This helps us avoid warnings on patterns that GHC elaborated.
+                --
+                -- NB: We have /already/ applied 'decideBangHood' to this
+                -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils"
+
+              , eqn_rest :: EquationInfo }
+                -- ^ The rest of the equation after its first pattern
+
+  | EqnDone
+  -- The empty tail of an equation having no more patterns
+            (MatchResult CoreExpr)
+            -- ^ What to do after match
+
+type EquationInfoNE = EquationInfo
+-- An EquationInfo which has at least one pattern
+
+prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo
+prependPats [] eqn = eqn
+prependPats (pat:pats) eqn = EqnMatch { eqn_pat = pat, eqn_rest = prependPats pats eqn }
+
+mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo
+mkEqnInfo pats = prependPats pats . EqnDone
+
+eqnMatchResult :: EquationInfo -> MatchResult CoreExpr
+eqnMatchResult (EqnDone rhs) = rhs
+eqnMatchResult (EqnMatch { eqn_rest = eq }) = eqnMatchResult eq
 
 instance Outputable EquationInfo where
-    ppr (EqnInfo pats _ _) = ppr pats
+    ppr = ppr . allEqnPats where
+      allEqnPats (EqnDone {}) = []
+      allEqnPats (EqnMatch { eqn_pat = pat, eqn_rest = eq }) = unLoc pat : allEqnPats eq
 
 type DsWrapper = CoreExpr -> CoreExpr
 idDsWrapper :: DsWrapper
@@ -357,7 +373,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
         lcl_env = DsLclEnv { dsl_meta        = emptyNameEnv
                            , dsl_loc         = real_span
                            , dsl_nablas      = initNablas
-                           , dsl_incoherents = mempty
+                           , dsl_unspecables = mempty
                            }
     in (gbl_env, lcl_env)
 
@@ -413,11 +429,11 @@ getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
 updPmNablas :: Nablas -> DsM a -> DsM a
 updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
 
-addIncoherents :: S.Set EvId -> DsM a -> DsM a
-addIncoherents incoherents = updLclEnv (\env -> env{ dsl_incoherents = incoherents `mappend` dsl_incoherents env })
+addUnspecables :: S.Set EvId -> DsM a -> DsM a
+addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env })
 
-getIncoherents :: DsM (S.Set EvId)
-getIncoherents = dsl_incoherents <$> getLclEnv
+getUnspecables :: DsM (S.Set EvId)
+getUnspecables = dsl_unspecables <$> getLclEnv
 
 getSrcSpanDs :: DsM SrcSpan
 getSrcSpanDs = do { env <- getLclEnv
@@ -443,6 +459,12 @@ diagnosticDs dsMessage
        ; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage
        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
+addMessagesDs :: Messages DsMessage -> DsM ()
+addMessagesDs msgs1
+  = do { msg_var <- ds_msgs <$> getGblEnv
+       ; msgs0 <- liftIO $ readIORef msg_var
+       ; liftIO $ writeIORef msg_var (msgs0 `unionMessages` msgs1) }
+
 -- | Issue an error, but return the expression for (), so that we can continue
 -- reporting errors.
 errDsCoreExpr :: DsMessage -> DsM CoreExpr
@@ -458,6 +480,13 @@ failWithDs msg
 failDs :: DsM a
 failDs = failM
 
+captureMessagesDs :: DsM a -> DsM (Messages DsMessage, a)
+captureMessagesDs thing_inside
+  = do { msg_var <- liftIO $ newIORef emptyMessages
+       ; res <- updGblEnv (\gbl -> gbl {ds_msgs = msg_var}) thing_inside
+       ; msgs <- liftIO $ readIORef msg_var
+       ; return (msgs, res) }
+
 mkNamePprCtxDs :: DsM NamePprCtx
 mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv
 

compiler/GHC/HsToCore/Pmc.hs

@@ -35,11 +35,12 @@
 --     'ldiMatch'. See Section 4.1 of the paper.
 module GHC.HsToCore.Pmc (
         -- Checking and printing
-        pmcPatBind, pmcMatches, pmcGRHSs,
+        pmcPatBind, pmcMatches, pmcGRHSs, pmcRecSel,
         isMatchContextPmChecked, isMatchContextPmChecked_SinglePat,
 
         -- See Note [Long-distance information]
-        addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas
+        addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas,
+        getNFirstUncovered
     ) where
 
 import GHC.Prelude
@@ -51,7 +52,7 @@ import GHC.HsToCore.Pmc.Desugar
 import GHC.HsToCore.Pmc.Check
 import GHC.HsToCore.Pmc.Solver
 import GHC.Types.Basic (Origin(..))
-import GHC.Core (CoreExpr)
+import GHC.Core
 import GHC.Driver.DynFlags
 import GHC.Hs
 import GHC.Types.Id
@@ -59,21 +60,20 @@ import GHC.Types.SrcLoc
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
-import GHC.Types.Var (EvVar)
+import GHC.Types.Var (EvVar, Var (..))
+import GHC.Types.Id.Info
 import GHC.Tc.Utils.TcType (evVarPred)
-import GHC.Tc.Utils.Monad (updTopFlags)
 import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
 import GHC.HsToCore.Monad
 import GHC.Data.Bag
-import GHC.Data.IOEnv (unsafeInterleaveM)
 import GHC.Data.OrdList
-import GHC.Utils.Monad (mapMaybeM)
 
 import Control.Monad (when, forM_)
 import qualified Data.Semigroup as Semi
 import Data.List.NonEmpty ( NonEmpty(..) )
 import qualified Data.List.NonEmpty as NE
 import Data.Coerce
+import GHC.Tc.Utils.Monad
 
 --
 -- * Exported entry points to the checker
@@ -193,9 +193,92 @@ pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
       {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
       return (NE.toList (ldiMatchGroup (cr_ret result)))
 
+{-
+Note [Detecting incomplete record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A record selector occurence is incomplete iff. it could fail due to
+being applied to a data type constructor not present for this record field.
+
+e.g.
+  data T = T1 | T2 {x :: Int}
+  d = x someComputation -- `d` may fail
+
+There are 4 parts to detecting and warning about
+incomplete record selectors to consider:
+
+  - Computing which constructors a general application of a record field will succeed on,
+    and which ones it will fail on. This is stored in the `sel_cons` field of
+    `IdDetails` datatype, which is a part of an `Id` and calculated when renaming a
+    record selector in `mkOneRecordSelector`
+
+  - Emitting a warning whenever a `HasField` constraint is solved.
+    This is checked in `matchHasField` and emitted only for when
+    the constraint is resolved with an implicit instance rather than a
+    custom one (since otherwise the warning will be emitted in
+      the custom implementation anyways)
+
+    e.g.
+      g :: HasField "x" t Int => t -> Int
+      g = getField @"x"
+
+      f :: T -> Int
+      f = g -- warning will be emitted here
+
+  - Emitting a warning for a general occurence of the record selector
+    This is done during the renaming of a `HsRecSel` expression in `dsExpr`
+    and simply pulls the information about incompleteness from the `Id`
+
+    e.g.
+      l :: T -> Int
+      l a = x a -- warning will be emitted here
+
+  - Emitting a warning for a record selector `sel` applied to a variable `y`.
+    In that case we want to use the long-distance information from the
+    pattern match checker to rule out impossible constructors
+    (See Note [Long-distance information]). We first add constraints to
+    the long-distance `Nablas` that `y` cannot be one of the constructors that
+    contain `sel` (function `checkRecSel` in GHC.HsToCore.Pmc.Check). If the
+    `Nablas` are still inhabited, we emit a warning with the inhabiting constructors
+    as examples of where `sel` may fail.
+
+    e.g.
+      z :: T -> Int
+      z T1 = 0
+      z a = x a -- warning will not be emitted here since `a` can only be `T2`
+-}
+
+pmcRecSel :: Id       -- ^ Id of the selector
+          -> CoreExpr -- ^ Core expression of the argument to the selector
+          -> DsM ()
+pmcRecSel sel_id arg
+  | RecSelId{ sel_cons = (cons_w_field, _ : _) } <- idDetails sel_id = do
+      !missing <- getLdiNablas
+
+      tracePm "pmcRecSel {" (ppr sel_id)
+      CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }
+        <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing
+      tracePm "}: " $ ppr uncov_nablas
+
+      inhabited <- isInhabited uncov_nablas
+      when inhabited $ warn_incomplete arg_id uncov_nablas
+        where
+          sel_name = varName sel_id
+          warn_incomplete arg_id uncov_nablas = do
+            dflags <- getDynFlags
+            let maxConstructors = maxUncoveredPatterns dflags
+            unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxConstructors + 1) uncov_nablas
+            let cons = [con | unc_example <- unc_examples
+                      , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]]
+                not_full_examples = length cons == (maxConstructors + 1)
+                cons' = take maxConstructors cons
+            diagnosticDs $ DsIncompleteRecordSelector sel_name cons' not_full_examples
+
+pmcRecSel _ _ = return ()
+
 {- Note [pmcPatBind doesn't warn on pattern guards]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 @pmcPatBind@'s main purpose is to check vanilla pattern bindings, like
+>>>>>>> 8760510af3 (This MR is an implementation of the proposal #516.)
 @x :: Int; Just x = e@, which is in a @PatBindRhs@ context.
 But its caller is also called for individual pattern guards in a @StmtCtxt@.
 For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will

compiler/GHC/HsToCore/Pmc/Check.hs

@@ -19,7 +19,7 @@
 -- "GHC.HsToCore.Pmc.Solver".
 module GHC.HsToCore.Pmc.Check (
         CheckAction(..),
-        checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase
+        checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase, checkRecSel
     ) where
 
 import GHC.Prelude
@@ -33,11 +33,15 @@ import GHC.Driver.DynFlags
 import GHC.Utils.Outputable
 import GHC.Tc.Utils.TcType (evVarPred)
 import GHC.Data.OrdList
+import GHC.Data.Bag
 
 import qualified Data.Semigroup as Semi
 import Data.List.NonEmpty ( NonEmpty(..) )
 import qualified Data.List.NonEmpty as NE
 import Data.Coerce
+import GHC.Types.Var
+import GHC.Core
+import GHC.Core.Utils
 
 -- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'.
 newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }
@@ -185,6 +189,20 @@ checkEmptyCase pe@(PmEmptyCase { pe_var = var }) = CA $ \inc -> do
 checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post)
 checkPatBind = coerce checkGRHS
 
+checkRecSel :: PmRecSel () -> CheckAction (PmRecSel Id)
+-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+checkRecSel pr@(PmRecSel { pr_arg = arg, pr_cons = cons }) = CA $ \inc -> do
+  arg_id <- case arg of
+           Var arg_id -> return arg_id
+           _ -> mkPmId $ exprType arg
+
+  let con_cts = map (PhiNotConCt arg_id . PmAltConLike) cons
+      arg_ct  = PhiCoreCt arg_id arg
+      phi_cts = listToBag (arg_ct : con_cts)
+  unc <- addPhiCtsNablas inc phi_cts
+  pure CheckResult { cr_ret = pr{ pr_arg_var = arg_id }, cr_uncov = unc, cr_approx = mempty }
+
+
 {- Note [Checking EmptyCase]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -XEmptyCase is useful for matching on empty data types like 'Void'. For example,

compiler/GHC/HsToCore/Pmc/Desugar.hs

@@ -123,6 +123,7 @@ desugarPat x pat = case pat of
   AsPat _ (L _ y) _ p -> (mkPmLetVar y x ++) <$> desugarLPat y p
 
   SigPat _ p _ty -> desugarLPat x p
+  EmbTyPat _ _ _ -> pure []
 
   XPat ext -> case ext of
 

compiler/GHC/HsToCore/Pmc/Types.hs

@@ -21,7 +21,8 @@ module GHC.HsToCore.Pmc.Types (
         SrcInfo(..), PmGrd(..), GrdVec(..),
 
         -- ** Guard tree language
-        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),
+        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..),
+        PmPatBind(..), PmEmptyCase(..), PmRecSel(..),
 
         -- * Coverage Checking types
         RedSets (..), Precision (..), CheckResult (..),
@@ -43,6 +44,7 @@ import GHC.Types.Id
 import GHC.Types.Var (EvVar)
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
+import GHC.Core.ConLike
 import GHC.Core.Type
 import GHC.Core
 
@@ -130,6 +132,8 @@ newtype PmPatBind p =
   -- rather than on the pattern bindings.
   PmPatBind (PmGRHS p)
 
+-- A guard tree denoting a record selector application
+data PmRecSel v = PmRecSel { pr_arg_var :: v, pr_arg :: CoreExpr, pr_cons :: [ConLike] }
 instance Outputable SrcInfo where
   ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss)
   ppr (SrcInfo (L s                   _)) = ppr s

compiler/GHC/HsToCore/Pmc/Utils.hs

@@ -61,6 +61,7 @@ allPmCheckWarnings =
   , Opt_WarnIncompleteUniPatterns
   , Opt_WarnIncompletePatternsRecUpd
   , Opt_WarnOverlappingPatterns
+  , Opt_WarnIncompleteRecordSelectors
   ]
 
 -- | Check whether the redundancy checker should run (redundancy only)