[Git][ghc/ghc][wip/expand-do] disallow overlapping warnings in do expansion generated match equations

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Fri May 19 17:24:18 UTC 2023



Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
b464815c by Apoorv Ingle at 2023-05-19T12:24:10-05:00
disallow overlapping warnings in do expansion generated match equations

- - - - -


9 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Types/Hint.hs
- utils/check-exact/ExactPrint.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1114,9 +1114,9 @@ data HsExpansion orig expanded
 -- | Just print the original expression (the @a@) with the expanded version (the @b@)
 instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
   ppr (HsExpanded orig expanded)
-    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
-               (ppr orig)
-    -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
+    -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+    --            (ppr orig)
+    = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
 
 
 {-


=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -345,8 +345,8 @@ subordinates env instMap decl = case decl of
   InstD _ (ClsInstD _ d) -> let
     data_fams = do
       DataFamInstDecl { dfid_eqn =
-        (FamEqn { feqn_tycon = L l _
-               , feqn_rhs   = defn })} <- unLoc <$> cid_datafam_insts d
+        FamEqn { feqn_tycon = L l _
+               , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d
       [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
     ty_fams = do
       TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ }) } <- unLoc <$> cid_tyfam_insts d


=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -28,7 +28,7 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
 
 import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
 
-import GHC.Types.Basic ( Origin(..), isGenerated )
+import GHC.Types.Basic ( Origin(..), isGenerated, GenReason (..))
 import GHC.Types.SourceText
 import GHC.Driver.Session
 import GHC.Hs
@@ -788,12 +788,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
         -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
         -- Each Match will split off one Nablas for its RHSs from this.
         ; tracePm "matchWrapper" (vcat [ ppr ctxt
+                                       , text "scrs" <+> ppr scrs
                                        , text "matches group" <+> ppr matches
                                        , text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)])
         ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
             then addHsScrutTmCs (concat scrs) new_vars $
                  -- See Note [Long-distance information]
-                 pmcMatches (DsMatchContext ctxt locn) new_vars matches
+                 pmcMatches origin (DsMatchContext ctxt locn) new_vars matches
             else pure (initNablasMatches matches)
 
         ; eqns_info   <- zipWithM mk_eqn_info matches matches_nablas
@@ -814,7 +815,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
            ; match_result <- updPmNablas pat_nablas $
                              dsGRHSs ctxt grhss rhs_ty rhss_nablas
            ; return EqnInfo { eqn_pats = upats
-                            , eqn_orig = FromSource
+                            , eqn_orig = origin -- Not all equations are from source
                             , eqn_rhs  = match_result } }
 
     handleWarnings = if isGenerated origin
@@ -834,7 +835,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
     is_pat_syn_match (Generated _) (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat
     is_pat_syn_match _ _ = False
     non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
-    non_wc (Generated _) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
+    non_wc (Generated DoExpansion) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
     non_wc _ _ = True
 
 matchEquations  :: HsMatchContext GhcRn


=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -50,7 +50,7 @@ import GHC.HsToCore.Pmc.Utils
 import GHC.HsToCore.Pmc.Desugar
 import GHC.HsToCore.Pmc.Check
 import GHC.HsToCore.Pmc.Solver
-import GHC.Types.Basic (Origin(..))
+import GHC.Types.Basic (Origin(..), isDoExpansionGenerated)
 import GHC.Core (CoreExpr)
 import GHC.Driver.Session
 import GHC.Hs
@@ -146,12 +146,13 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
 -- checks and @-XEmptyCase@ with only a single match variable.
 -- See Note [Checking EmptyCase].
 pmcMatches
-  :: DsMatchContext                  -- ^ Match context, for warnings messages
+  :: Origin
+  -> DsMatchContext                  -- ^ Match context, for warnings messages
   -> [Id]                            -- ^ Match variables, i.e. x and y above
   -> [LMatch GhcTc (LHsExpr GhcTc)]  -- ^ List of matches
   -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and
                                      --   GRHS, for long distance info.
-pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
+pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
   -- We have to force @missing@ before printing out the trace message,
   -- otherwise we get interleaved output from the solver. This function
   -- should be strict in @missing@ anyway!
@@ -175,7 +176,9 @@ pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
       result  <- {-# SCC "checkMatchGroup" #-}
                  unCA (checkMatchGroup matches) missing
       tracePm "}: " (ppr (cr_uncov result))
-      {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
+      when (not (isDoExpansionGenerated origin))
+        ({-# SCC "formatReportWarnings" #-}
+        formatReportWarnings ReportMatchGroup ctxt vars result)
       return (NE.toList (ldiMatchGroup (cr_ret result)))
 
 {- Note [pmcPatBind only checks PatBindRhs]


=====================================
compiler/GHC/HsToCore/Pmc/Utils.hs
=====================================
@@ -120,8 +120,10 @@ isMatchContextPmChecked dflags origin kind
 -- are enabled, in which case we need to run the pattern match checker.
 needToRunPmCheck :: DynFlags -> Origin -> Bool
 needToRunPmCheck dflags origin
+  | isDoExpansionGenerated origin
+  = False
   | isGenerated origin
-   = True
+  = True
   | otherwise
   = notNull (filter (`wopt` dflags) allPmCheckWarnings)
 


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -408,26 +408,24 @@ tcExpr (HsMultiIf _ alts) res_ty
        ; return (HsMultiIf res_ty alts') }
   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
 
-tcExpr (HsDo _ doFlav@(DoExpr{}) (L loc stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
   = do { expand_expr <- expandDoStmts doFlav stmts
-       ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts))
-                                               (unLoc expand_expr)
-                                        -- Do expansion on the fly
-       ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
-                                      , text "expanded:" <+> ppr expand_expr
-                                      ])
-       ; tcExpr expand_do_expr res_ty
+                                               -- Do expansion on the fly
+       ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
+       ; traceTc "tcDoStmts doExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
+                                          , text "expanded:" <+> ppr expand_expr
+                                          ])
+       ; tcExpr expanded_do_expr res_ty
        }
 
-tcExpr (HsDo _ doFlav@(MDoExpr{}) (L loc stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
   = do { expand_expr <- expandDoStmts doFlav stmts
-       ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts))
-                                               (unLoc expand_expr)
-                                        -- Do expansion on the fly
-       ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr
-                                      , text "expanded:" <+> ppr expand_expr
-                                      ])
-       ; tcExpr expand_do_expr res_ty
+                                               -- Do expansion on the fly
+       ; let expanded_do_expr = mkExpandedExpr hsDo (unLoc expand_expr)
+       ; traceTc "tcDoStmts mDoExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
+                                           , text "expanded:" <+> ppr expand_expr
+                                           ])
+       ; tcExpr expanded_do_expr res_ty
        }
 
 tcExpr (HsDo _ do_or_lc stmts) res_ty


=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -1644,10 +1644,8 @@ isIrrefutableHsPatRn tc_env is_strict pat =
     go (AsPat _ _ _ pat)   = goL pat
     go (ViewPat _ _ pat)   = goL pat
     go (SigPat _ pat _)    = goL pat
-    go (TuplePat _ pats _) =
-      do traceTc "isIrrefutableHsPatRn TuplePat" empty
-         foldM (\a p -> do {b <- goL p; return (a && b)}) True pats
-
+    go (TuplePat _ pats _) = do bs <- mapM goL pats
+                                return (and bs)
     go (SumPat {})         = return False
                     -- See Note [Unboxed sum patterns aren't irrefutable]
     go (ListPat {})        = return False
@@ -1656,31 +1654,21 @@ isIrrefutableHsPatRn tc_env is_strict pat =
         { pat_con  = L _ dcName
         , pat_args = details }) =
       do { tyth <- tcLookupGlobal dcName
-         ; traceTc "isIrrefutableHsPatRn dataCon" (ppr tyth)
+         ; traceTc "isIrrefutableHsPatRn TyThing" (ppr tyth)
          ; case tyth of
               (ATyCon tycon) ->
-                   do { b <- foldM (\a p -> do {b <- goL p; return (a && b)}) True (hsConPatArgs details)
-                      ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon
-                                                      , ppr (isNewTyCon tycon)
-                                                      , ppr (tcHasFixedRuntimeRep tycon)])
+                   do { bs <- mapM goL (hsConPatArgs details)
                       ; let b' = isJust (tyConSingleDataCon_maybe tycon)
-                      ; return (b && b') }
-              id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
+                      ; return (b' && and bs) }
               (AConLike cl) ->
                    case cl of
                        RealDataCon dc ->
                          do let tycon = dataConTyCon dc
-                            b <- foldM (\a p -> do {b <- goL p; return (a && b)})
-                                   True (hsConPatArgs details)
-                            traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon
-                                                                     , ppr (isNewTyCon tycon)
-                                                                     , ppr (tcHasFixedRuntimeRep tycon)] )
                             let b' = isJust (tyConSingleDataCon_maybe tycon)
-                            return (b && b')
-                       PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con)
-                                           return False -- conservative
-
-              ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
+                            bs <- mapM goL (hsConPatArgs details)
+                            return (b' && and bs)
+                       PatSynCon _pat -> return False -- conservative
+              _ -> pprPanic "isIrrefutableHsPatRn" (ppr tyth)
           }
     go (LitPat {})         = do traceTc "isIrrefutableHsPatRn LitPat" empty
                                 return False


=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -40,7 +40,7 @@ import GHC.Types.SrcLoc (SrcSpan)
 import GHC.Types.Basic (Activation, RuleName)
 import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) )
 import GHC.Parser.Errors.Basic
-import {-# SOURCE #-} Language.Haskell.Syntax.Expr
+import Language.Haskell.Syntax.Expr
 import GHC.Unit.Module.Imported (ImportedModsVal)
 import GHC.Data.FastString (fsLit)
 import Language.Haskell.Syntax (LPat, LIdP)


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2672,6 +2672,7 @@ instance ExactPrint (HsExpr GhcPs) where
   getAnnotationEntry (HsProc an _ _)              = fromAnn an
   getAnnotationEntry (HsStatic an _)              = fromAnn an
   getAnnotationEntry (HsPragE{})                  = NoEntryVal
+  getAnnotationEntry (PopSrcSpan{})               = NoEntryVal
 
   setAnnotationAnchor a@(HsVar{})              _ _s = a
   setAnnotationAnchor (HsUnboundVar an a)    anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)
@@ -2710,6 +2711,7 @@ instance ExactPrint (HsExpr GhcPs) where
   setAnnotationAnchor (HsProc an a b)         anc cs = (HsProc (setAnchorEpa an anc cs) a b)
   setAnnotationAnchor (HsStatic an a)         anc cs = (HsStatic (setAnchorEpa an anc cs) a)
   setAnnotationAnchor a@(HsPragE{})            _ _s = a
+  setAnnotationAnchor a@(PopSrcSpan{})         _ _s = a
 
   exact (HsVar x n) = do
     n' <- markAnnotated n



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b464815c8a09fb8273009a652caf716a1ee6920e
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/20230519/caab08d9/attachment-0001.html>


More information about the ghc-commits mailing list