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

[Apoorv Ingle (@ani)]

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


Commits:
5de3533e by Apoorv Ingle at 2023-04-18T18:32:41-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
@@ -851,6 +852,35 @@ 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 f <- fish_var fun
+  , is_gen_then f
+  = warnDiscardedDoBindings arg arg_ty
+  where
+    fish_var :: LHsExpr GhcTc -> Maybe (LIdP GhcTc)
+    fish_var (L _ (HsVar _ id)) = return id
+    fish_var (L _ (HsAppType _ e _ _)) = do e' <- fish_var e
+                                            return e'
+    fish_var (L _ (HsApp _ e _)) = do e' <- fish_var e
+                                      return e'
+    fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do e' <- fish_var (L l e)
+                                                        return e'
+    fish_var _ = Nothing
+
+    is_gen_then :: LIdP GhcTc -> Bool
+    is_gen_then (L (SrcSpanAnn _ l) f) = f `hasKey` thenMClassOpKey && isNoSrcSpan l
+
+warnUnusedBindValue _ _ _  = return ()
+
+
+-- is this expr a compiler generated (>>)
+
+
 {-
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -397,44 +397,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
=====================================
@@ -38,10 +38,10 @@ 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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5de3533e8d18a7a4562e0a310ae54ee8da406477
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/20230418/d8a9893c/attachment-0001.html>