[Git][ghc/ghc][wip/T25281] Now working I think

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Mon Sep 30 23:40:45 UTC 2024



Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC


Commits:
ba79e31c by Simon Peyton Jones at 2024-10-01T00:40:23+01:00
Now working I think

- - - - -


13 changed files:

- compiler/GHC/Core/LateCC/OverloadedCalls.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/CtLoc.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Validity.hs
- testsuite/tests/pmcheck/should_compile/T24891.hs


Changes:

=====================================
compiler/GHC/Core/LateCC/OverloadedCalls.hs
=====================================
@@ -26,7 +26,6 @@ import GHC.Types.Name
 import GHC.Types.SrcLoc
 import GHC.Types.Tickish
 import GHC.Types.Var
-import GHC.Utils.Outputable
 
 type OverloadedCallsCCState = Strict.Maybe SrcSpan
 


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -723,21 +723,16 @@ ds_app_var (L loc fun_id) hs_args core_args
   -- Alas, we cannot simply look at the unfolding of $dHasField below because it
   -- has not been set yet, so we have to reconstruct the selector Id from the types.
   | fun_id `hasKey` getFieldClassOpKey
-  , (_k : _rrep : _arep : Type x_ty : Type r_ty : _) <- core_args
-    -- getField :: forall {k} {r_rep} {a_rep} (x::k) (r :: TYPE r_rep) (a :: TYPE a_rep) .
-    --             HasField x r a => r -> a
-  = do { fam_inst_envs <- dsGetFamInstEnvs
+  = do {  -- Look up the field named x/"sel" in the type r/T
+         fam_inst_envs <- dsGetFamInstEnvs
        ; rdr_env       <- dsGetGlobalRdrEnv
-          -- Look up the field named x/"sel" in the type r/T
-       ; tracePm "getfield" (ppr core_args $$ ppr x_ty $$ ppr r_ty)
-       ; case lookupHasFieldLabel fam_inst_envs x_ty r_ty of
-          Just fl | isJust (lookupGRE_FieldLabel rdr_env fl)
-                    -- isJust: Make sure the field is actually visible in this module;
-                    -- otherwise this might not be the implicit HasField instance
-                 -> do { sel_id <- dsLookupGlobalId (flSelector fl)
-                       ; tracePm "getfield2" (ppr sel_id)
-                       ; ds_app_rec_sel sel_id fun_id core_args }
-          _      -> ds_app_finish fun_id core_args }
+       ; let core_arg_tys :: [Type] = [ty | Type ty <- core_args]
+       ; case lookupHasFieldLabel fam_inst_envs rdr_env core_arg_tys of
+           Just (sel_name,_,_,_)
+             -> do { sel_id <- dsLookupGlobalId sel_name
+                   ; tracePm "getfield2" (ppr sel_id)
+                   ; ds_app_rec_sel sel_id fun_id core_args }
+           _ -> ds_app_finish fun_id core_args }
 
   -----------------------
   -- Warn about identities for (fromInteger :: Integer -> Integer) etc


=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.HsToCore.Types (
         DsMetaEnv, DsMetaVal(..), CompleteMatches
     ) where
 
-import GHC.Prelude (Int, Bool)
+import GHC.Prelude (Int)
 
 import Data.IORef
 import qualified Data.Set as S


=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -2313,7 +2313,7 @@ mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEm
     report_no_fieldnames item
        | Just (EvVarDest evvar) <- ei_evdest item
        -- we can assume that here we have a `HasField @Symbol x r a` instance
-       -- because of HasFieldOrigin in record_field
+       -- because of GetFieldOrigin in record_field
        , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar)
        , Just (r_tycon, _) <- tcSplitTyConApp_maybe r
        , Just x_name <- isStrLitTy x
@@ -2328,7 +2328,7 @@ mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEm
       isNothing (lookupLocalRdrOcc lcl_env occ_name)
 
     record_field = case orig of
-      HasFieldOrigin name -> Just (mkVarOccFS name)
+      GetFieldOrigin name -> Just (mkVarOccFS name)
       _                   -> Nothing
 
     cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -403,18 +403,10 @@ tcApp rn_expr exp_res_ty
        ; (tc_fun, fun_sigma) <- tcInferAppHead fun
        ; let tc_head = (tc_fun, fun_ctxt)
 
-       ; let supp_incomplete_rec_sel
-               | XExpr (ExpandedThingRn (OrigExpr HsGetField{}) _) <- rn_expr
-               -- See (7) of Note [Detecting incomplete record selectors]
-               = setSuppressIncompleteRecSelsTc True
-               | otherwise
-               = id
-
        -- Step 3: Instantiate the function type (taking a quick look at args)
        ; do_ql <- wantQuickLook rn_fun
        ; (inst_args, app_res_rho)
-              <- supp_incomplete_rec_sel $
-                 setQLInstLevel do_ql $  -- See (TCAPP1) and (TCAPP2) in
+              <- setQLInstLevel do_ql $  -- See (TCAPP1) and (TCAPP2) in
                                          -- Note [tcApp: typechecking applications]
                  tcInstFun do_ql True tc_head fun_sigma rn_args
 
@@ -772,9 +764,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
            ; go (pos+1) (addArgWrap wrap acc) inst_body rest_args }
 
     go1 pos acc fun_ty (EWrap w : args)
-      = setSuppressIncompleteRecSelsTc False $
-        -- See (7) of Note [Detecting incomplete record selectors]
-        go1 pos (EWrap w : acc) fun_ty args
+      = go1 pos (EWrap w : acc) fun_ty args
 
     go1 pos acc fun_ty (EPrag sp prag : args)
       = go1 pos (EPrag sp prag : acc) fun_ty args


=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -22,7 +22,8 @@ import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType)
 import GHC.Tc.Instance.Typeable
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
+import GHC.Tc.Types.CtLoc
+import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
 import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs )
 import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
 
@@ -65,7 +66,6 @@ import GHC.Hs.Extension
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 import GHC.Types.Id.Info
 import GHC.Tc.Errors.Types
-import Control.Monad
 
 import Data.Functor
 import Data.Maybe
@@ -138,11 +138,12 @@ instanceReturnsDictCon LocalInstance       = False
 matchGlobalInst :: DynFlags
                 -> Bool      -- True <=> caller is the short-cut solver
                              -- See Note [Shortcut solving: overlap]
-                -> Class -> [Type] -> TcM ClsInstResult
+                -> Class -> [Type] -> Maybe CtLoc
+                -> TcM ClsInstResult
 -- Precondition: Class does not satisfy GHC.Core.Predicate.isEqualityClass
 -- (That is handled by a separate code path: see GHC.Tc.Solver.Dict.solveDict,
 --  which calls solveEqualityDict for equality classes.)
-matchGlobalInst dflags short_cut clas tys
+matchGlobalInst dflags short_cut clas tys mb_loc
   | cls_name == knownNatClassName      = matchKnownNat    dflags short_cut clas tys
   | cls_name == knownSymbolClassName   = matchKnownSymbol dflags short_cut clas tys
   | cls_name == knownCharClassName     = matchKnownChar   dflags short_cut clas tys
@@ -150,7 +151,7 @@ matchGlobalInst dflags short_cut clas tys
   | cls_name == typeableClassName      = matchTypeable                     clas tys
   | cls_name == withDictClassName      = matchWithDict                          tys
   | cls_name == dataToTagClassName     = matchDataToTag                    clas tys
-  | cls_name == hasFieldClassName      = matchHasField    dflags short_cut clas tys
+  | cls_name == hasFieldClassName      = matchHasField    dflags short_cut clas tys mb_loc
   | cls_name == unsatisfiableClassName = return NoInstance -- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors
   | otherwise                          = matchInstEnv     dflags short_cut clas tys
   where
@@ -1246,20 +1247,14 @@ addUsedGRE extends tcg_used_gres with imported GREs only.
 -}
 
 -- See Note [HasField instances]
-matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
-matchHasField dflags short_cut clas tys
+matchHasField :: DynFlags -> Bool -> Class -> [Type] -> Maybe CtLoc
+              -> TcM ClsInstResult
+matchHasField dflags short_cut clas tys mb_ct_loc
   = do { fam_inst_envs <- tcGetFamInstEnvs
        ; rdr_env       <- getGlobalRdrEnv
-       ; case tys of
-           -- We are matching HasField {k} {r_rep} {a_rep} x r a...
-           [_k_ty, _r_rep, _a_rep, x_ty, r_ty, a_ty]
-               -- Look up the field named x in the type r
-             | Just fl <- lookupHasFieldLabel fam_inst_envs x_ty r_ty
-               -- and ensure the field selector is in scope
-             , Just gre <- lookupGRE_FieldLabel rdr_env fl
-
-             -> do { let name = flSelector fl
-                   ; sel_id <- tcLookupId name
+       ; case lookupHasFieldLabel fam_inst_envs rdr_env tys of
+            Just (sel_name, gre, r_ty, a_ty) ->
+                do { sel_id <- tcLookupId sel_name
                    ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
 
                          -- The first new wanted constraint equates the actual
@@ -1289,35 +1284,61 @@ matchHasField dflags short_cut clas tys
                    ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
                      then do { -- See Note [Unused name reporting and HasField]
                                addUsedGRE AllDeprecationWarnings gre
-                             ; keepAlive name
-                             ; let maxCons = maxUncoveredPatterns dflags
-                             ; let fallible_cons = rsi_undef $ sel_cons $ idDetails sel_id
-                             ; suppress <- getSuppressIncompleteRecSelsTc
-                               -- See (7) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
-                             ; unless (null fallible_cons || suppress) $ do
-                                 addDiagnostic $ TcRnHasFieldResolvedIncomplete name fallible_cons maxCons
+                             ; keepAlive sel_name
+                             ; warnIncompleteRecSel dflags sel_id mb_ct_loc
                              ; return OneInst { cir_new_theta   = theta
                                               , cir_mk_ev       = mk_ev
                                               , cir_canonical   = EvCanonical
                                               , cir_what        = BuiltinInstance } }
                      else matchInstEnv dflags short_cut clas tys }
 
-           _ -> matchInstEnv dflags short_cut clas tys }
+            Nothing -> matchInstEnv dflags short_cut clas tys }
+
+warnIncompleteRecSel :: DynFlags -> Id -> Maybe CtLoc -> TcM ()
+warnIncompleteRecSel dflags sel_id mb_ct_loc
+  | Just ct_loc <- mb_ct_loc
+  , not (isGetFieldOrigin (ctLocOrigin ct_loc))
+  , not (null fallible_cons)
+  = traceTc "tc-warn" (ppr sel_id $$ ppr (ctLocOrigin ct_loc))  >>
+    (setCtLocM ct_loc $ addDiagnostic $
+     TcRnHasFieldResolvedIncomplete (idName sel_id) fallible_cons maxCons)
 
-lookupHasFieldLabel :: FamInstEnvs -> Type -> Type -> Maybe FieldLabel
+  | otherwise
+  = return ()
+  where
+    maxCons = maxUncoveredPatterns dflags
+    fallible_cons = rsi_undef $ sel_cons $ idDetails sel_id
+
+    -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,
+    -- despite the expansion to (getField @"x" r)
+    isGetFieldOrigin (GetFieldOrigin {}) = True
+    isGetFieldOrigin _                   = False
+
+lookupHasFieldLabel
+  :: FamInstEnvs -> GlobalRdrEnv -> [Type]
+  -> Maybe ( Name          -- Name of the record selector
+           , GlobalRdrElt  -- GRE for the selector
+           , Type          -- Type of the record value
+           , Type )        -- Type of the field of the record
 -- The call (lookupHasFieldLabel fam_envs (LitTy "fld") (T t1..tn))
--- returns the `FieldLabel` of field "fld" in the data type T.
+-- returns the `Name` of record selector Id for field "fld" in the data type T.
 -- A complication is that `T` might be a data family, so we need to
 -- look it up in the `fam_envs` to find its representation tycon.
-lookupHasFieldLabel fam_inst_envs x_ty r_ty
+lookupHasFieldLabel fam_inst_envs rdr_env arg_tys
+  |  -- We are matching HasField {k} {r_rep} {a_rep} x r a...
+    (_k_ty : _r_rep : _a_rep : x_ty : r_ty : a_ty : _) <- arg_tys
+               -- Look up the field named x in the type r
     -- x should be a literal string
-  | Just x <- isStrLitTy x_ty
+  , Just x <- isStrLitTy x_ty
     -- r should be an applied type constructor
   , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
     -- use representation tycon (if data family); it has the fields
   , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
     -- x should be a field of r
-  = lookupTyConFieldLabel (FieldLabelString x) r_tc
+  , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc
+     -- and ensure the field selector is in scope
+  , Just gre <- lookupGRE_FieldLabel rdr_env fl
+  = Just (flSelector fl, gre, r_ty, a_ty)
 
   | otherwise
   = Nothing


=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1663,7 +1663,7 @@ matchGlobalInst :: DynFlags
                              -- See Note [Shortcut solving: overlap]
                 -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult
 matchGlobalInst dflags short_cut cls tys loc
-  = wrapTcS $ TcM.setCtLocM loc $ TcM.matchGlobalInst dflags short_cut cls tys
+  = wrapTcS $ TcM.matchGlobalInst dflags short_cut cls tys (Just loc)
 
 tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar])
 tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs


=====================================
compiler/GHC/Tc/Types/CtLoc.hs
=====================================
@@ -229,8 +229,7 @@ data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt]
                          , ctl_bndrs :: !TcBinderStack
                          , ctl_tclvl :: !TcLevel
                          , ctl_in_gen_code :: !Bool
-                         , ctl_rdr :: !LocalRdrEnv
-                         , ctl_suppress_incomplete_rec_sels :: !Bool }
+                         , ctl_rdr :: !LocalRdrEnv }
 
 getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan
 getCtLocEnvLoc = ctl_loc


=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -12,7 +12,6 @@ module GHC.Tc.Types.LclEnv (
   , getLclEnvRdrEnv
   , getLclEnvTcLevel
   , getLclEnvThStage
-  , getLclEnvSuppressIncompleteRecSels
   , setLclEnvTcLevel
   , setLclEnvLoc
   , setLclEnvRdrEnv
@@ -20,7 +19,6 @@ module GHC.Tc.Types.LclEnv (
   , setLclEnvErrCtxt
   , setLclEnvThStage
   , setLclEnvTypeEnv
-  , setLclEnvSuppressIncompleteRecSels
   , modifyLclEnvTcLevel
 
   , lclEnvInGeneratedCode
@@ -119,11 +117,8 @@ data TcLclCtxt
 
         tcl_arrow_ctxt :: ArrowCtxt,       -- Arrow-notation context
 
-        tcl_env  :: TcTypeEnv,   -- The local type environment:
+        tcl_env  :: TcTypeEnv    -- The local type environment:
                                  -- Ids and TyVars defined in this module
-
-        tcl_suppress_incomplete_rec_sel :: Bool -- True <=> Suppress warnings about incomplete record selectors
-                                                -- See (7) of Note [Detecting incomplete record selectors]
     }
 
 getLclEnvThStage :: TcLclEnv -> ThStage
@@ -183,12 +178,6 @@ getLclEnvRdrEnv = tcl_rdr . tcl_lcl_ctxt
 setLclEnvRdrEnv :: LocalRdrEnv -> TcLclEnv -> TcLclEnv
 setLclEnvRdrEnv rdr_env = modifyLclCtxt (\env -> env { tcl_rdr = rdr_env })
 
-getLclEnvSuppressIncompleteRecSels :: TcLclEnv -> Bool
-getLclEnvSuppressIncompleteRecSels = tcl_suppress_incomplete_rec_sel . tcl_lcl_ctxt
-
-setLclEnvSuppressIncompleteRecSels :: Bool -> TcLclEnv -> TcLclEnv
-setLclEnvSuppressIncompleteRecSels suppress = modifyLclCtxt (\env -> env { tcl_suppress_incomplete_rec_sel = suppress })
-
 modifyLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv
 modifyLclCtxt upd env =
   let !res = upd (tcl_lcl_ctxt env)


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -544,7 +544,7 @@ data CtOrigin
                         -- IMPORTANT: These constraints will never cause errors;
                         -- See Note [Constraints to ignore] in GHC.Tc.Errors
   | SectionOrigin
-  | HasFieldOrigin FastString
+  | GetFieldOrigin FastString
   | TupleOrigin         -- (..,..)
   | ExprSigOrigin       -- e :: ty
   | PatSigOrigin        -- p :: ty
@@ -716,7 +716,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
 
 exprCtOrigin :: HsExpr GhcRn -> CtOrigin
 exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
-exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f)
+exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
 exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable"
 exprCtOrigin (HsRecSel _ f)       = OccurrenceOfRecSel (unLoc $ foLabel f)
 exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l
@@ -915,7 +915,7 @@ pprCtO ViewPatOrigin         = text "a view pattern"
 pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
 pprCtO SectionOrigin         = text "an operator section"
-pprCtO (HasFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)]
+pprCtO (GetFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)]
 pprCtO AssocFamPatOrigin     = text "the LHS of a family instance"
 pprCtO TupleOrigin           = text "a tuple"
 pprCtO NegateOrigin          = text "a use of syntactic negation"


=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -94,7 +94,6 @@ module GHC.Tc.Utils.Monad(
   mkTcRnMessage, reportDiagnostic, reportDiagnostics,
   warnIf, diagnosticTc, diagnosticTcM,
   addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,
-  getSuppressIncompleteRecSelsTc, setSuppressIncompleteRecSelsTc,
 
   -- * Type constraints
   newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
@@ -400,8 +399,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
                 tcl_arrow_ctxt = NoArrowCtxt,
                 tcl_env        = emptyNameEnv,
                 tcl_bndrs      = [],
-                tcl_tclvl      = topTcLevel,
-                tcl_suppress_incomplete_rec_sel = False
+                tcl_tclvl      = topTcLevel
                 },
                 tcl_usage      = usage_var,
                 tcl_lie        = lie_var,
@@ -1276,7 +1274,6 @@ mkCtLocEnv lcl_env =
            , ctl_tclvl = getLclEnvTcLevel lcl_env
            , ctl_in_gen_code = lclEnvInGeneratedCode lcl_env
            , ctl_rdr = getLclEnvRdrEnv lcl_env
-           , ctl_suppress_incomplete_rec_sels = getLclEnvSuppressIncompleteRecSels lcl_env
            }
 
 setCtLocM :: CtLoc -> TcM a -> TcM a
@@ -1285,7 +1282,6 @@ setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
   = updLclEnv (\env -> setLclEnvLoc (ctl_loc lcl)
                      $ setLclEnvErrCtxt (ctl_ctxt lcl)
                      $ setLclEnvBinderStack (ctl_bndrs lcl)
-                     $ setLclEnvSuppressIncompleteRecSels (ctl_suppress_incomplete_rec_sels lcl)
                      $ env) thing_inside
 
 {- *********************************************************************
@@ -1667,13 +1663,6 @@ add_diagnostic msg
        ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
        }
 
-getSuppressIncompleteRecSelsTc :: TcRn Bool
-getSuppressIncompleteRecSelsTc = getLclEnvSuppressIncompleteRecSels <$> getLclEnv
-
-setSuppressIncompleteRecSelsTc :: Bool -> TcRn a -> TcRn a
-setSuppressIncompleteRecSelsTc b = updLclEnv (setLclEnvSuppressIncompleteRecSels b)
-
-
 {-
 -----------------------------------
         Other helper functions


=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -1400,7 +1400,7 @@ checkSimplifiableClassConstraint env dflags ctxt cls tys
                 -- (Coercible a b) to (a ~R# b)
 
   | otherwise
-  = do { result <- matchGlobalInst dflags False cls tys
+  = do { result <- matchGlobalInst dflags False cls tys Nothing
        ; case result of
            OneInst { cir_what = what }
               -> addDiagnosticTc (TcRnSimplifiableConstraint pred what)


=====================================
testsuite/tests/pmcheck/should_compile/T24891.hs
=====================================
@@ -12,7 +12,6 @@ data T a where
 f :: T Bool -> Int
 f x = x.sel -- warn, but only once, suggesting to match on T3
 
-{-
 data Dot = No | Yes {sel2 :: Int}
 
 ldiDot :: Dot -> Int
@@ -29,4 +28,4 @@ data Dot2 t = No2 | Yes2 {sel3 :: t}
 
 accessDot2 :: HasField "sel2" t Int => Dot2 t -> Int
 accessDot2 x = x.sel3.sel2 -- warn about x.sel3
--}
+



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba79e31c58c8f1260e081dec07478628fba82e38

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba79e31c58c8f1260e081dec07478628fba82e38
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/20240930/173523a1/attachment-0001.html>


More information about the ghc-commits mailing list