[Git][ghc/ghc][wip/expand-do] changes to correctly identify the `>>` function and emitting warning if a...

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Fri Apr 21 00:23:37 UTC 2023



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


Commits:
26ceda8b by Apoorv Ingle at 2023-04-20T19:23:26-05:00
changes to correctly identify the `>>` function and emitting warning if a value of non-unit type is used in a do block expanded generated code

- - - - -


8 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/deSugar/should_compile/T3263-2.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2011,13 +2011,6 @@ matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")
 matchDoContextErrString ListComp     = text "list comprehension"
 matchDoContextErrString MonadComp    = text "monad comprehension"
 
-instance Outputable HsDoFlavour where
-  ppr (DoExpr m) = text "DoExpr" <+> parens (ppr m)
-  ppr (MDoExpr m) = text "MDoExpr" <+> parens (ppr m)
-  ppr GhciStmtCtxt = text "GhciStmtCtxt"
-  ppr ListComp = text "ListComp"
-  ppr MonadComp = text "MonadComp"
-
 pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
                => Match (GhcPass idR) body -> SDoc
 pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -307,6 +307,7 @@ dsExpr (HsLamCase _ lc_variant matches)
 dsExpr e@(HsApp _ fun arg)
   = do { fun' <- dsLExpr fun
        ; arg' <- dsLExpr arg
+       ; warnUnusedBindValue fun arg (exprType arg')
        ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
 
 dsExpr e@(HsAppType {}) = dsHsWrapped e
@@ -682,7 +683,7 @@ dsDo ctx stmts
 
     go _ (BodyStmt _ rhs then_expr _) stmts
       = do { rhs2 <- dsLExpr rhs
-           ; warnDiscardedDoBindings rhs (exprType rhs2)
+           --; warnDiscardedDoBindings rhs (exprType rhs2)
            ; rest <- goL stmts
            ; dsSyntaxExpr then_expr [rhs2, rest] }
 
@@ -851,6 +852,29 @@ warnDiscardedDoBindings rhs rhs_ty
   | otherwise   -- RHS does have type of form (m ty), which is weird
   = return ()   -- but at least this warning is irrelevant
 
+
+warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
+warnUnusedBindValue fun arg arg_ty
+  | Just (SrcSpanAnn _ l, f) <- fish_var fun
+  , is_gen_then f
+  , isNoSrcSpan l
+  = warnDiscardedDoBindings arg arg_ty
+  where
+    -- retrieve the location info and the head of the application
+    fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc)
+    fish_var (L l (HsVar _ id)) = return (l, id)
+    fish_var (L _ (HsAppType _ e _ _)) = fish_var e
+    fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
+                                                        return (l, e')
+    fish_var _ = Nothing
+
+    -- is this id a compiler generated (>>) with expanded do
+    is_gen_then :: LIdP GhcTc -> Bool
+    is_gen_then (L _ f) = f `hasKey` thenMClassOpKey
+
+warnUnusedBindValue _ _ _  = return ()
+
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1304,7 +1304,6 @@ instance Diagnostic TcRnMessage where
     TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $
        sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"
                        , text "in" <+> pprAStmtContext ctxt ]
-    TcRnUnUsedDoBind ty -> mkSimpleDecorated $ pprBadMonadBind ty
     TcRnIllegalTupleSection -> mkSimpleDecorated $
       text "Illegal tuple section"
     TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $
@@ -2136,8 +2135,6 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnLastStmtNotExpr{}
       -> ErrorWithoutFlag
-    TcRnUnUsedDoBind{}
-      -> WarningWithFlag Opt_WarnUnusedDoBind
     TcRnUnexpectedStatementInContext{}
       -> ErrorWithoutFlag
     TcRnSectionWithoutParentheses{}
@@ -2721,8 +2718,6 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnLastStmtNotExpr{}
       -> noHints
-    TcRnUnUsedDoBind {}
-      -> noHints
     TcRnUnexpectedStatementInContext _ _ mExt
       | Nothing <- mExt -> noHints
       | Just ext <- mExt -> [suggestExtension ext]
@@ -5039,6 +5034,50 @@ pprPatSynInvalidRhsReason = \case
     text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
   PatSynUnboundVar var ->
     quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"
+pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc
+pprBadFieldAnnotationReason = \case
+  LazyFieldsDisabled ->
+    text "Lazy field annotations (~) are disabled"
+  UnpackWithoutStrictness ->
+    text "UNPACK pragma lacks '!'"
+  BackpackUnpackAbstractType ->
+    text "Ignoring unusable UNPACK pragma"
+
+pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc
+pprSuperclassCycleDetail = \case
+  SCD_HeadTyVar pred ->
+    hang (text "one of whose superclass constraints is headed by a type variable:")
+       2 (quotes (ppr pred))
+  SCD_HeadTyFam pred ->
+    hang (text "one of whose superclass constraints is headed by a type family:")
+       2 (quotes (ppr pred))
+  SCD_Superclass cls ->
+    text "one of whose superclasses is" <+> quotes (ppr cls)
+
+pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc
+pprRoleValidationFailedReason role = \case
+  TyVarRoleMismatch tv role' ->
+    text "type variable" <+> quotes (ppr tv) <+>
+    text "cannot have role" <+> ppr role <+>
+    text "because it was assigned role" <+> ppr role'
+  TyVarMissingInEnv tv ->
+    text "type variable" <+> quotes (ppr tv) <+> text "missing in environment"
+  BadCoercionRole co ->
+    text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role
+
+pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc
+pprDisabledClassExtension cls = \case
+  MultiParamDisabled n ->
+    text howMany <+> text "parameters for class" <+> quotes (ppr cls)
+    where
+      howMany | n == 0 = "No"
+              | otherwise = "Too many"
+  FunDepsDisabled ->
+    text "Fundeps in class" <+> quotes (ppr cls)
+  ConstrainedClassMethodsDisabled sel_id pred ->
+    vcat [ hang (text "Constraint" <+> quotes (ppr pred)
+                 <+> text "in the type of" <+> quotes (ppr sel_id))
+              2 (text "constrains only the class type variables")]
 
 pprBadMonadBind :: Type -> SDoc
 pprBadMonadBind elt_ty


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2903,17 +2903,6 @@ data TcRnMessage where
     -> Maybe LangExt.Extension
     -> TcRnMessage
 
-  {-| A do statment that discards a non-unit value
-      Example: do return 10  -- value discarded
-                  return 10
-
-      Test cases: testsuite/tests/deSugar/should_compile/T3263-2
-
-  -}
-  TcRnUnUsedDoBind
-    :: Type
-    -> TcRnMessage
-    
   {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section
       without enabling the TupleSections extension.
 


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -39,7 +39,6 @@ import GHC.Core.TyCo.Subst (substTyWithInScope)
 import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType )
 import GHC.Core.Type
 import GHC.Core.Coercion
-import GHC.Core.FamInstEnv
 import GHC.Tc.Types.Evidence
 import GHC.Types.Var.Set
 import GHC.Builtin.PrimOps( tagToEnumKey )
@@ -328,7 +327,7 @@ tcApp rn_expr exp_res_ty
            vcat [ text "rn_fun:" <+> ppr rn_fun
                 , text "rn_args:" <+> ppr rn_args ]
        ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
-       
+
        -- Instantiate
        ; do_ql <- wantQuickLook rn_fun
        ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args
@@ -397,44 +396,9 @@ tcApp rn_expr exp_res_ty
                                       , text "tc_args:"     <+> ppr tc_args
                                       , text "tc_expr:"     <+> ppr tc_expr ]) }
 
-       -- Emit a warning if the bind value in a do statement is discarded
-       ; warnUnusedBindValue rn_fun tc_args
-
        -- Wrap the result
        ; return (mkHsWrap res_wrap tc_expr) }
 
--- emit a warning if the argument expression is not of type unit
-warnUnusedBindValue :: HsExpr GhcRn -> [HsExprArg 'TcpTc] -> TcM ()
-warnUnusedBindValue fun args
-  | is_gen_then fun
-  , (_ : _ : arg : _) <- args
-  = do { -- arg <- zonkArg arg
-         fam_inst_envs <- tcGetFamInstEnvs
-       ; let app_ty' = (scaledThing . eva_arg_ty) arg -- usually /m a/
-       ; app_ty <- zonkTcType app_ty'
-       ; let (_, (ret_ty':_)) = tcSplitAppTys app_ty  -- /a/
-       ; ret_ty <- zonkTcType ret_ty' -- ANI this maynot work as ret_ty' is an unsolved type variable and it gives rise to spurious unused bind warnings
-       ; let norm_elt_ty = topNormaliseType fam_inst_envs ret_ty
-                           -- normalize /a/ as it might be a type family 
-             not_unit_ty = (not . isUnitTy) norm_elt_ty
-                           -- is /a/ not /()/?
-       ; traceTc "warnUnusedBindValue" (vcat [ text "arg" <+> ppr arg
-                                             , text "arg_ty" <+> ppr (eva_arg_ty arg)
-                                             , text "app_ty" <+> ppr app_ty
-                                             , text "split" <+> ppr (tcSplitAppTys app_ty)
-                                             , text "norm_elt_ty" <+> ppr norm_elt_ty
-                                             ])
-       ; diagnosticTc not_unit_ty (TcRnUnUsedDoBind norm_elt_ty)
-       }
-  where
-    -- is this function a generated (>>)
-    is_gen_then :: HsExpr GhcRn -> Bool
-    is_gen_then (HsVar _ (L (SrcSpanAnn _ l) fun)) = fun `hasKey` thenMClassOpKey
-                                                    && isNoSrcSpan l
-    is_gen_then _ = False
-
-warnUnusedBindValue _ _ = return ()
-  
 --------------------
 wantQuickLook :: HsExpr GhcRn -> TcM Bool
 wantQuickLook (HsVar _ (L _ f))


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1238,7 +1238,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
                                 ]
 
   | otherwise = -- just use the Prelude.>>= TODO: Necessary?
---                          stmts ~~> stmts'    
+--                          stmts ~~> stmts'
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (Prelude.>>=) e (\ pat -> stmts')
       do traceTc "expand_do_stmts: generic binop" empty


=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -430,12 +430,15 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnIllegalStaticFormInSplice"                 = 12219
   GhcDiagnosticCode "TcRnListComprehensionDuplicateBinding"         = 81232
   GhcDiagnosticCode "TcRnLastStmtNotExpr"                           = 55814
-  GhcDiagnosticCode "TcRnUnUsedDoBind"                              = 61315
   GhcDiagnosticCode "TcRnUnexpectedStatementInContext"              = 42026
   GhcDiagnosticCode "TcRnSectionWithoutParentheses"                 = 95880
   GhcDiagnosticCode "TcRnIllegalImplicitParameterBindings"          = 50730
   GhcDiagnosticCode "TcRnIllegalTupleSection"                       = 59155
   GhcDiagnosticCode "TcRnTermNameInType"                            = 37479
+  GhcDiagnosticCode "TcRnUnexpectedKindVar"                         = 12875
+  GhcDiagnosticCode "TcRnNegativeNumTypeLiteral"                    = 93632
+  GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar"                   = 54180
+
   GhcDiagnosticCode "TcRnUntickedPromotedThing"                     = 49957
   GhcDiagnosticCode "TcRnIllegalBuiltinSyntax"                      = 39716
   GhcDiagnosticCode "TcRnWarnDefaulting"                            = 18042


=====================================
testsuite/tests/deSugar/should_compile/T3263-2.hs
=====================================
@@ -14,14 +14,14 @@ t2 :: Monad m => m (m Int)
 t2 = return (return 10)
 
 -- No warning
-t3 :: Monad m => m (m Int)
-t3 = do
+asdft3 :: Monad m => m (m Int)
+asdft3 = do
   return 10
   return (return 10)
 
 -- Warning
-t4 :: forall m. Monad m => m Int
-t4 = do
+asdft4 :: forall m. Monad m => m Int
+asdft4 = do
   return (return 10 :: m Int)
   return 10
 
@@ -38,11 +38,15 @@ t6 = mdo
   return (return 10 :: m Int)
   return 10
 
--- unit :: ()
+unit :: ()
 unit = ()
 
--- No warning
+-- -- No warning
 t7 :: forall m. Monad m => m Int
 t7 = do
   return unit
   return 10
+
+-- No warning
+t8 :: Monad m => m Int
+t8 = return 10 >> return 10



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/26ceda8b61582ea23a23f9fee4bc9ed59c62235d
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/20230420/96b3bac0/attachment-0001.html>


More information about the ghc-commits mailing list