From 99478003846d35dd8c4401be90ce91f8a825fd59 Mon Sep 17 00:00:00 2001
From: Sebastian Graf <sgraf1337@gmail.com>
Date: Sun, 16 Jun 2019 11:52:43 +0200
Subject: Move 'Useless SPECIALISE pragma' warnings to TcWarnings

---
 compiler/deSugar/DsBinds.hs      | 17 +----------------
 compiler/typecheck/TcHsSyn.hs    |  4 +++-
 compiler/typecheck/TcWarnings.hs | 29 ++++++++++++++++++++++++++++-
 3 files changed, 32 insertions(+), 18 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index a87a4bbcbb..b7a77a8bf0 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -653,22 +653,6 @@ dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
        -> Located TcSpecPrag
        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
 dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
-  | isJust (isClassOpId_maybe poly_id)
-  = putSrcSpanDs loc $
-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
-                          <+> quotes (ppr poly_id))
-       ; return Nothing  }  -- There is no point in trying to specialise a class op
-                            -- Moreover, classops don't (currently) have an inl_sat arity set
-                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
-
-  | no_act_spec && isNeverActive rule_act
-  = putSrcSpanDs loc $
-    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
-                          <+> quotes (ppr poly_id))
-       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
-                            -- See Note [Activation pragmas for SPECIALISE]
-
-  | otherwise
   = putSrcSpanDs loc $
     do { uniq <- newUnique
        ; let poly_name = idName poly_id
@@ -746,6 +730,7 @@ dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
     -- See Note [Activation pragmas for SPECIALISE]
     -- no_act_spec is True if the user didn't write an explicit
     -- phase specification in the SPECIALISE pragma
+    -- Keep this in sync with 'TcWarnings.warnUnusedSpecialisePragma'
     no_act_spec = case inlinePragmaSpec spec_inl of
                     NoInline -> isNeverActive  spec_prag_act
                     _        -> isAlwaysActive spec_prag_act
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index ded91a6b78..efda5a7f69 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -682,7 +682,9 @@ zonkLTcSpecPrags env ps
   where
     zonk_prag (dL->L loc (SpecPrag id co_fn inl))
         = do { (_, co_fn') <- zonkCoFn env co_fn
-             ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+             ; let prag = cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)
+             ; warnUselessSpecialisePragma prag
+             ; return prag }
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcWarnings.hs b/compiler/typecheck/TcWarnings.hs
index f0d1a21acc..2c89ead806 100644
--- a/compiler/typecheck/TcWarnings.hs
+++ b/compiler/typecheck/TcWarnings.hs
@@ -9,7 +9,10 @@ module TcWarnings (
     warnAboutEmptyEnumerations,
 
     -- * Discarded do bindings
-    warnDiscardedDoBindings
+    warnDiscardedDoBindings,
+
+    -- * Useless pragmas
+    warnUselessSpecialisePragma
   ) where
 
 import GhcPrelude
@@ -274,3 +277,27 @@ badMonadBind rhs elt_ty
          , hang (text "Suppress this warning by saying")
               2 (quotes $ text "_ <-" <+> ppr rhs)
          ]
+
+warnUselessSpecialisePragma :: LTcSpecPrag -> TcM ()
+warnUselessSpecialisePragma (dL->L loc (SpecPrag id _ spec_inl))
+  | Just _ <- isClassOpId_maybe id
+  = setSrcSpan loc (warn_useless "class method selector")
+  | no_act_spec && isNeverActive id_rule_act
+  -- Function is NOINLINE, and the specialisation inherits that
+  -- See Note [Activation pragmas for SPECIALISE] in DsBinds
+  = setSrcSpan loc (warn_useless "NOINLINE function")
+  | otherwise
+  = return ()
+  where
+    warn_useless what = warnTc NoReason True $ hsep
+      [ text "Ignoring useless SPECIALISE pragma for"
+      , ppr what
+      , quotes (ppr id)
+      ]
+    -- See Note [Activation pragmas for SPECIALISE] in DsBinds
+    -- no_act_spec is True if the user didn't write an explicit
+    -- phase specification in the SPECIALISE pragma
+    no_act_spec = case inlinePragmaSpec spec_inl of
+                    NoInline -> isNeverActive  (inlinePragmaActivation spec_inl)
+                    _        -> isAlwaysActive (inlinePragmaActivation spec_inl)
+    id_rule_act = inlinePragmaActivation (idInlinePragma id)
-- 
cgit v1.2.1