[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
Thu Apr 20 23:55:08 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
b27bd49f by Apoorv Ingle at 2023-04-20T18:55:02-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
- - - - -
3 changed files:
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- testsuite/tests/deSugar/should_compile/T3263-2.hs
Changes:
=====================================
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,31 @@ 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
+-- -- | is_gen_then (unLoc fun)
+-- = warnDiscardedDoBindings arg arg_ty
+warnUnusedBindValue fun arg arg_ty
+ | Just (SrcSpanAnn _ l, f) <- fish_var fun
+ , is_gen_then f
+ , isNoSrcSpan l
+ = warnDiscardedDoBindings arg arg_ty
+ where
+ 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 expr a compiler generated (>>)
+ is_gen_then :: LIdP GhcTc -> Bool
+ is_gen_then (L _ f) = f `hasKey` thenMClassOpKey -- && isNoSrcSpan l
+
+warnUnusedBindValue _ _ _ = return ()
+
+
{-
************************************************************************
* *
=====================================
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 )
@@ -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))
=====================================
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/b27bd49f81a399e3d73f929efd2409d73bb705f5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b27bd49f81a399e3d73f929efd2409d73bb705f5
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/91d15fac/attachment-0001.html>
More information about the ghc-commits
mailing list