[Git][ghc/ghc][wip/T8671] Suppresses spurious warnings generated for do-body statements that

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/T8671 at Glasgow Haskell Compiler / GHC


Commits:
2ef26d79 by Apoorv Ingle at 2024-04-18T16:21:46-05:00
Suppresses spurious warnings generated for do-body statements that
in really do not discard anything. This improves usability of RebindableSyntax and Qualified Do.

Fixes: #8671

- - - - -


8 changed files:

- compiler/GHC/HsToCore/Expr.hs
- + testsuite/tests/qualifieddo/should_compile/T8671a.hs
- + testsuite/tests/qualifieddo/should_compile/T8671adefs.hs
- + testsuite/tests/qualifieddo/should_compile/T8671b.hs
- + testsuite/tests/qualifieddo/should_compile/T8671bdefs.hs
- testsuite/tests/qualifieddo/should_compile/all.T
- + testsuite/tests/rebindable/T8671.hs
- testsuite/tests/rebindable/all.T


Changes:

=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -978,8 +978,11 @@ warnDiscardedDoBindings rhs rhs_ty
     do { fam_inst_envs <- dsGetFamInstEnvs
        ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
 
-           -- Warn about discarding non-() things in 'monadic' binding
-       ; if warn_unused && not (isUnitTy norm_elt_ty)
+       -- Warn about discarding non-() things in 'monadic' binding
+       -- We also check that the type is not empty via `isEmptyTy` as
+       -- there may be non-unit but empty types which we can suppress spurious discard warnings
+       -- See #8671 and tests T8671.hs, T8671a.hs, T8671b.hs
+       ; if warn_unused && not (isUnitTy norm_elt_ty) && not (isEmptyTy norm_elt_ty)
          then diagnosticDs (DsUnusedDoBind rhs elt_ty)
          else
 


=====================================
testsuite/tests/qualifieddo/should_compile/T8671a.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# OPTIONS_GHC "-Wunused-do-bind" #-}
+
+module Example where
+
+import T8671adefs qualified as Q
+
+example :: Q.NotMonad 2
+example = Q.do
+  Q.incr
+  Q.incr


=====================================
testsuite/tests/qualifieddo/should_compile/T8671adefs.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+
+module T8671adefs where
+
+import GHC.TypeLits
+
+-- Not actually a useful thing, but illustrates the point
+data NotMonad (t :: Nat)
+
+incr :: NotMonad 1
+incr = undefined
+
+(>>) :: NotMonad s -> NotMonad t -> NotMonad (s + t)
+(>>) = undefined


=====================================
testsuite/tests/qualifieddo/should_compile/T8671b.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# OPTIONS_GHC "-Wunused-do-bind" #-}
+
+module Example where
+
+import T8671bdefs qualified as Q
+
+example :: Q.NotMonad Bool
+example = Q.do
+  Q.bool 1 2
+  Q.bool 3 4


=====================================
testsuite/tests/qualifieddo/should_compile/T8671bdefs.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds #-}
+
+module T8671bdefs where
+
+
+data NotMonad t = NotMonad
+  {unNotMonad :: t -> Int}
+
+run :: t -> NotMonad t -> Int
+run t (NotMonad f) = f t
+
+(>>) :: NotMonad t -> NotMonad t -> NotMonad t
+NotMonad l >> NotMonad r = NotMonad $ \t -> l t + r t
+
+bool :: Int -> Int -> NotMonad Bool
+bool t f = NotMonad (\b -> if b then t else f)


=====================================
testsuite/tests/qualifieddo/should_compile/all.T
=====================================
@@ -1,4 +1,7 @@
 setTestOpts(only_ways(['normal']));
 
+# qextra_files = extra_files(['T8671adefs.hs', 'T8671bdefs.hs'])
 test('qdocompile001', normal, compile, ['-v0 -ddump-rn -dsuppress-uniques'])
 test('qdocompile002', normal, compile, ['-v0'])
+test('T8671a', normal, compile, ['--make -v0 -Wall -Wunused-do-bind -i./'])
+test('T8671b', normal, compile, ['--make -v0 -Wall -Wunused-do-bind -i./'])
\ No newline at end of file


=====================================
testsuite/tests/rebindable/T8671.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE RebindableSyntax #-}
+
+module T8671 where
+
+import Data.Void
+import Prelude ((.), ($), Int, id, Num(..))
+
+
+(>>) :: (b -> c) -> (a -> b) -> (a -> c)
+(>>) = (.)
+
+
+return :: Void -> Void
+return = absurd
+
+
+run :: a -> (a -> b) -> b
+run x f = f x
+
+
+result :: Int
+result = run 8 $ do
+    \n -> n * n
+    id
+    (+ 7)
+    (* 2)


=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -46,3 +46,4 @@ test('T20126', normal, compile_fail, [''])
 test('T23147', normal, compile, [''])
 test('pattern-fails', normal, compile_and_run, [''])
 test('simple-rec', normal, compile_and_run, [''])
+test('T8671', normal, compile, ['-v0 -Wall -Wunused-do-bind'])
\ No newline at end of file



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ef26d79110b1ef614bb235c5e8c30e36ff337c0
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/20240418/eb5acae3/attachment-0001.html>