Fix #16282.

Previously, -W(all-)missed-specs was created with 'NoReason',
so no information about the flag was printed along with the warning.
Now, -Wall-missed-specs is listed as the Reason if it was set,
otherwise -Wmissed-specs is listed as the reason.

5 files changed, 51 insertions, 24 deletions

diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index d99686aa20..013b1414ee 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -778,8 +778,8 @@ we aren't using annotations heavily.
 ************************************************************************
 -}
 
-msg :: Severity -> SDoc -> CoreM ()
-msg sev doc
+msg :: Severity -> WarnReason -> SDoc -> CoreM ()
+msg sev reason doc
   = do { dflags <- getDynFlags
        ; loc    <- getSrcSpanM
        ; unqual <- getPrintUnqualified
@@ -791,7 +791,7 @@ msg sev doc
              err_sty  = mkErrStyle dflags unqual
              user_sty = mkUserStyle dflags unqual AllTheWay
              dump_sty = mkDumpStyle dflags unqual
-       ; liftIO $ putLogMsg dflags NoReason sev loc sty doc }
+       ; liftIO $ putLogMsg dflags reason sev loc sty doc }
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
@@ -799,7 +799,7 @@ putMsgS = putMsg . text
 
 -- | Output a message to the screen
 putMsg :: SDoc -> CoreM ()
-putMsg = msg SevInfo
+putMsg = msg SevInfo NoReason
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsgS :: String -> CoreM ()
@@ -807,9 +807,9 @@ errorMsgS = errorMsg . text
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsg :: SDoc -> CoreM ()
-errorMsg = msg SevError
+errorMsg = msg SevError NoReason
 
-warnMsg :: SDoc -> CoreM ()
+warnMsg :: WarnReason -> SDoc -> CoreM ()
 warnMsg = msg SevWarning
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
@@ -818,7 +818,7 @@ fatalErrorMsgS = fatalErrorMsg . text
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsg :: SDoc -> CoreM ()
-fatalErrorMsg = msg SevFatal
+fatalErrorMsg = msg SevFatal NoReason
 
 -- | Output a string debugging message at verbosity level of @-v@ or higher
 debugTraceMsgS :: String -> CoreM ()
@@ -826,7 +826,7 @@ debugTraceMsgS = debugTraceMsg . text
 
 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 debugTraceMsg :: SDoc -> CoreM ()
-debugTraceMsg = msg SevDump
+debugTraceMsg = msg SevDump NoReason
 
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index c62789017f..9d87abc1ad 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -730,28 +730,35 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn
 
        ; return (rules2 ++ rules1, final_binds) }
 
-  |  warnMissingSpecs dflags callers
-  = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))
-                            2 (vcat [ text "when specialising" <+> quotes (ppr caller)
-                                    | caller <- callers])
-                      , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
-                      , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
-       ; return ([], []) }
+  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn
+                   ; return ([], [])}
 
-  | otherwise
-  = return ([], [])
   where
     unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
 
-warnMissingSpecs :: DynFlags -> [Id] -> Bool
+-- | Returns whether or not to show a missed-spec warning.
+-- If -Wall-missed-specializations is on, show the warning.
+-- Otherwise, if -Wmissed-specializations is on, only show a warning
+-- if there is at least one imported function being specialized,
+-- and if all imported functions are marked with an inline pragma
+-- Use the most specific warning as the reason.
+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
 -- See Note [Warning about missed specialisations]
-warnMissingSpecs dflags callers
-  | wopt Opt_WarnAllMissedSpecs dflags = True
-  | not (wopt Opt_WarnMissedSpecs dflags) = False
-  | null callers                       = False
-  | otherwise                          = all has_inline_prag callers
+tryWarnMissingSpecs dflags callers fn calls_for_fn
+  | wopt Opt_WarnMissedSpecs dflags
+    && not (null callers)
+    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs
+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs
+  | otherwise                             = return ()
   where
-    has_inline_prag id = isAnyInlinePragma (idInlinePragma id)
+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
+    doWarn reason = 
+      warnMsg reason
+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)
+                        | caller <- callers])
+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
 
 wantSpecImport :: DynFlags -> Unfolding -> Bool
 -- See Note [Specialise imported INLINABLE things]
diff --git a/testsuite/tests/warnings/should_compile/T16282/T16282.hs b/testsuite/tests/warnings/should_compile/T16282/T16282.hs
new file mode 100644
index 0000000000..0f6ab866a0
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T16282/T16282.hs
@@ -0,0 +1,14 @@
+import Data.Map

+

+-- If someone improves the specializer so that

+-- GHC no longer misses the specialization below,

+-- then this test will fail, as it expects a warning

+-- to be issued.

+-- Another reason this could fail is due to spelling:

+-- the test checks for the "specialisation" spelling,

+-- but due to changes in how the warnings are listed in DynFalgs.hs

+-- the compiler may spit out the "specialization" spelling.

+main :: IO ()

+main = do

+  let m = [] :: [Map String Bool]

+  mapM_ print m

diff --git a/testsuite/tests/warnings/should_compile/T16282/T16282.stderr b/testsuite/tests/warnings/should_compile/T16282/T16282.stderr
new file mode 100644
index 0000000000..3af33f12a2
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T16282/T16282.stderr
@@ -0,0 +1,5 @@
+

+T16282.hs: warning: [-Wall-missed-specialisations]

+    Could not specialise imported function ‘Data.Map.Internal.$w$cshowsPrec’

+      when specialising ‘Data.Map.Internal.$fShowMap_$cshowsPrec’

+    Probable fix: add INLINABLE pragma on ‘Data.Map.Internal.$w$cshowsPrec’

diff --git a/testsuite/tests/warnings/should_compile/T16282/all.T b/testsuite/tests/warnings/should_compile/T16282/all.T
new file mode 100644
index 0000000000..dfcdd0562a
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T16282/all.T
@@ -0,0 +1 @@
+test('T16282', normal, compile, ['-O2 -Wall-missed-specialisations'])
\ No newline at end of file