[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