Filter out completely warnings not enabled by user (#263)

* Filter out completely warnings not enabled by user

* Suggestions by @cocreature

* Add tests

* Work more on tests

* Fix tests

Author: serras

exe/Main.hs

@@ -150,7 +150,7 @@ kick = do
 showEvent :: Lock -> FromServerMessage -> IO ()
 showEvent _ (EventFileDiagnostics _ []) = return ()
 showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
-    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
+    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
 showEvent lock e = withLock lock $ print e
 
 

src/Development/IDE/Core/Compile.hs

@@ -108,13 +108,7 @@ typecheckModule (IdeDefer defer) packageState deps pm =
                 GHC.typecheckModule $ enableTopLevelWarnings
                                     $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
             tcm2 <- mkTcModuleResult tcm
-            let errorPipeline = unDefer
-                              . (if wopt Opt_WarnMissingSignatures dflags
-                                    then id
-                                    else degradeError Opt_WarnMissingSignatures)
-                              . (if wopt Opt_WarnMissingLocalSignatures dflags
-                                    then id
-                                    else degradeError Opt_WarnMissingLocalSignatures)
+            let errorPipeline = unDefer . hideDiag dflags
             return (map errorPipeline warnings, tcm2)
 
 initPlugins :: GhcMonad m => ModSummary -> m ModSummary
@@ -182,7 +176,9 @@ demoteTypeErrorsToWarnings =
 enableTopLevelWarnings :: ParsedModule -> ParsedModule
 enableTopLevelWarnings =
   (update_pm_mod_summary . update_hspp_opts)
-  ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))
+  (`wopt_set` Opt_WarnMissingSignatures)
+  -- the line below would show also warnings for let bindings without signature
+  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))
 
 update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
 update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
@@ -197,20 +193,16 @@ unDefer (Reason Opt_WarnTypedHoles                 , fd) = upgradeWarningToError
 unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd
 unDefer ( _                                        , fd) = fd
 
-degradeError :: WarningFlag -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
-degradeError f (Reason f', fd)
-  | f == f'        = (Reason f', degradeWarningToError fd)
-degradeError _ wfd = wfd
-
 upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
-upgradeWarningToError (nfp, fd) =
-  (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
+upgradeWarningToError (nfp, sh, fd) =
+  (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
   warn2err :: T.Text -> T.Text
   warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
 
-degradeWarningToError :: FileDiagnostic -> FileDiagnostic
-degradeWarningToError (nfp, fd) =
-  (nfp, fd{_severity = Just DsInfo})
+hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
+hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
+  | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
+hideDiag _originalFlags t = t 
 
 addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
 addRelativeImport fp modu dflags = dflags

src/Development/IDE/Core/Rules.hs

@@ -229,7 +229,7 @@ reportImportCyclesRule =
     where cycleErrorInFile f (PartOfCycle imp fs)
             | f `elem` fs = Just (imp, fs)
           cycleErrorInFile _ _ = Nothing
-          toDiag imp mods = (fp ,) $ Diagnostic
+          toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic
             { _range = (_range :: Location -> Range) loc
             , _severity = Just DsError
             , _source = Just "Import cycle detection"

src/Development/IDE/Core/Shake.hs

@@ -28,6 +28,7 @@ module Development.IDE.Core.Shake(
     use_, useNoFile_, uses_,
     define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
     getDiagnostics, unsafeClearDiagnostics,
+    getHiddenDiagnostics,
     IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
     garbageCollect,
     setPriority,
@@ -93,6 +94,7 @@ data ShakeExtras = ShakeExtras
     ,globals :: Var (HMap.HashMap TypeRep Dynamic)
     ,state :: Var Values
     ,diagnostics :: Var DiagnosticStore
+    ,hiddenDiagnostics :: Var DiagnosticStore
     ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
     -- ^ This represents the set of diagnostics that we have published.
     -- Due to debouncing not every change might get published.
@@ -289,6 +291,7 @@ shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgr
         globals <- newVar HMap.empty
         state <- newVar HMap.empty
         diagnostics <- newVar mempty
+        hiddenDiagnostics <- newVar mempty
         publishedDiagnostics <- newVar mempty
         debouncer <- newDebouncer
         positionMapping <- newVar Map.empty
@@ -400,6 +403,11 @@ getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
     val <- readVar diagnostics
     return $ getAllDiagnostics val
 
+getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
+getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
+    val <- readVar hiddenDiagnostics
+    return $ getAllDiagnostics val
+
 -- | FIXME: This function is temporary! Only required because the files of interest doesn't work
 unsafeClearDiagnostics :: IdeState -> IO ()
 unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
@@ -408,12 +416,13 @@ unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
 -- | Clear the results for all files that do not match the given predicate.
 garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
 garbageCollect keep = do
-    ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
+    ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
     liftIO $
         do newState <- modifyVar state $ \values -> do
                values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
                return $! dupe values
            modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
+           modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
            modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
            let versionsForFile =
                    Map.fromListWith Set.union $
@@ -528,7 +537,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
                             Failed -> (toShakeValue ShakeResult bs, Failed)
                 Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
             liftIO $ setValues state key file res
-            updateFileDiagnostics file (Key key) extras $ map snd diags
+            updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
             let eq = case (bs, fmap decodeShakeValue old) of
                     (ShakeResult a, Just (ShakeResult b)) -> a == b
                     (ShakeStale a, Just (ShakeStale b)) -> a == b
@@ -589,7 +598,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
       case mbOld of
           Nothing -> do
               (diags, mbHash) <- runAct
-              updateFileDiagnostics file (Key key) extras $ map snd diags
+              updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
               pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
           Just old -> do
               current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
@@ -600,7 +609,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
                     pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
                   else do
                     (diags, mbHash) <- runAct
-                    updateFileDiagnostics file (Key key) extras $ map snd diags
+                    updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
                     let change
                           | mbHash == Just old = ChangedRecomputeSame
                           | otherwise = ChangedRecomputeDiff
@@ -656,21 +665,30 @@ updateFileDiagnostics ::
      NormalizedFilePath
   -> Key
   -> ShakeExtras
-  -> [Diagnostic] -- ^ current results
+  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
   -> Action ()
-updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
+updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
     modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
+    let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
         -- published. Otherwise, we might never publish certain diagnostics if
         -- an exception strikes between modifyVar but before
         -- publishDiagnosticsNotification.
         newDiags <- modifyVar diagnostics $ \old -> do
-            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
+            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
+                                  (T.pack $ show k) (map snd currentShown) old
             let newDiags = getFileDiagnostics fp newDiagsStore
             _ <- evaluate newDiagsStore
             _ <- evaluate newDiags
             pure $! (newDiagsStore, newDiags)
+        modifyVar_ hiddenDiagnostics $ \old -> do
+            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
+                                  (T.pack $ show k) (map snd currentHidden) old
+            let newDiags = getFileDiagnostics fp newDiagsStore
+            _ <- evaluate newDiagsStore
+            _ <- evaluate newDiags
+            return newDiagsStore
         let uri = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri $ do
@@ -751,7 +769,7 @@ getAllDiagnostics ::
     DiagnosticStore ->
     [FileDiagnostic]
 getAllDiagnostics =
-    concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
+    concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList
 
 getFileDiagnostics ::
     NormalizedFilePath ->

src/Development/IDE/GHC/Error.hs

@@ -34,7 +34,7 @@ import qualified Outputable                 as Out
 
 
 diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
-diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,)
+diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)
     Diagnostic
     { _range    = srcSpanToRange loc
     , _severity = Just sev

src/Development/IDE/LSP/CodeAction.hs

@@ -59,9 +59,10 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
       Just (toNormalizedFilePath -> filePath) -> do
         _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
         diag <- getDiagnostics ideState
+        hDiag <- getHiddenDiagnostics ideState
         pure $ List
           [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
-          | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag
+          | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag
           , dFile == filePath
           , (title, tedit) <- suggestSignature False dDiag
           , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

src/Development/IDE/Types/Diagnostics.hs

@@ -4,6 +4,7 @@
 
 module Development.IDE.Types.Diagnostics (
   LSP.Diagnostic(..),
+  ShowDiagnostic(..),
   FileDiagnostic,
   LSP.DiagnosticSeverity(..),
   DiagnosticStore,
@@ -13,6 +14,7 @@ module Development.IDE.Types.Diagnostics (
   showDiagnosticsColored,
   ) where
 
+import Control.DeepSeq
 import Data.Maybe as Maybe
 import qualified Data.Text as T
 import Data.Text.Prettyprint.Doc
@@ -30,7 +32,7 @@ import Development.IDE.Types.Location
 
 
 ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
-ideErrorText fp msg = (fp, LSP.Diagnostic {
+ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {
     _range = noRange,
     _severity = Just LSP.DsError,
     _code = Nothing,
@@ -39,14 +41,28 @@ ideErrorText fp msg = (fp, LSP.Diagnostic {
     _relatedInformation = Nothing
     })
 
+-- | Defines whether a particular diagnostic should be reported
+--   back to the user.
+--
+--   One important use case is "missing signature" code lenses,
+--   for which we need to enable the corresponding warning during
+--   type checking. However, we do not want to show the warning
+--   unless the programmer asks for it (#261).
+data ShowDiagnostic
+    = ShowDiag  -- ^ Report back to the user
+    | HideDiag  -- ^ Hide from user
+    deriving (Eq, Ord, Show)
+
+instance NFData ShowDiagnostic where
+    rnf = rwhnf
 
 -- | Human readable diagnostics for a specific file.
 --
 --   This type packages a pretty printed, human readable error message
 --   along with the related source location so that we can display the error
 --   on either the console or in the IDE at the right source location.
 --
-type FileDiagnostic = (NormalizedFilePath, Diagnostic)
+type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)
 
 prettyRange :: Range -> Doc Terminal.AnsiStyle
 prettyRange Range{..} = f _start <> "-" <> f _end
@@ -66,9 +82,10 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
 prettyDiagnostics = vcat . map prettyDiagnostic
 
 prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
-prettyDiagnostic (fp, LSP.Diagnostic{..}) =
+prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =
     vcat
         [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fp)
+        , slabel_ "Hidden:  " $ if sh == ShowDiag then "no" else "yes"
         , slabel_ "Range:   " $ prettyRange _range
         , slabel_ "Source:  " $ pretty _source
         , slabel_ "Severity:" $ pretty $ show sev

test/exe/Main.hs

@@ -39,6 +39,7 @@ main = defaultMain $ testGroup "HIE"
   , initializeResponseTests
   , diagnosticTests
   , codeActionTests
+  , codeLensesTests
   , findDefinitionAndHoverTests
   , pluginTests
   , thTests
@@ -385,6 +386,11 @@ codeActionTests = testGroup "code actions"
   , addSigActionTests
   ]
 
+codeLensesTests :: TestTree
+codeLensesTests = testGroup "code lenses"
+  [ addSigLensesTests
+  ]
+
 renameActionTests :: TestTree
 renameActionTests = testGroup "rename actions"
   [ testSession "change to local variable name" $ do
@@ -673,14 +679,14 @@ fillTypedHoleTests = let
 
 addSigActionTests :: TestTree
 addSigActionTests = let
-  header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
-                     , "module Sigs where"]
-  before  def     = T.unlines [header,      def]
-  after'  def sig = T.unlines [header, sig, def]
+  header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"
+  moduleH = "module Sigs where"
+  before def     = T.unlines [header, moduleH,      def]
+  after' def sig = T.unlines [header, moduleH, sig, def]
 
   def >:: sig = testSession (T.unpack def) $ do
     let originalCode = before def
-    let expectedCode = after'  def sig
+    let expectedCode = after' def sig
     doc <- openDoc' "Sigs.hs" "haskell" originalCode
     _ <- waitForDiagnostics
     actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
@@ -690,13 +696,52 @@ addSigActionTests = let
     liftIO $ expectedCode @=? modifiedCode
   in
   testGroup "add signature"
-  [ "abc = True"             >:: "abc :: Bool"
-  , "foo a b = a + b"        >:: "foo :: Num a => a -> a -> a"
-  , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
-  , "(!!!) a b = a > b"      >:: "(!!!) :: Ord a => a -> a -> Bool"
-  , "a >>>> b = a + b"       >:: "(>>>>) :: Num a => a -> a -> a"
-  , "a `haha` b = a b"       >:: "haha :: (t1 -> t2) -> t1 -> t2"
-  ]
+    [ "abc = True"             >:: "abc :: Bool"
+    , "foo a b = a + b"        >:: "foo :: Num a => a -> a -> a"
+    , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
+    , "(!!!) a b = a > b"      >:: "(!!!) :: Ord a => a -> a -> Bool"
+    , "a >>>> b = a + b"       >:: "(>>>>) :: Num a => a -> a -> a"
+    , "a `haha` b = a b"       >:: "haha :: (t1 -> t2) -> t1 -> t2"
+    ]
+
+addSigLensesTests :: TestTree
+addSigLensesTests = let
+  missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"
+  notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
+  moduleH = "module Sigs where"
+  other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
+  before  withMissing def
+    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
+  after'  withMissing def sig
+    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]
+
+  sigSession withMissing def sig = testSession (T.unpack def) $ do
+    let originalCode = before withMissing def
+    let expectedCode = after' withMissing def sig
+    doc <- openDoc' "Sigs.hs" "haskell" originalCode
+    [CodeLens {_command = Just c}] <- getCodeLenses doc
+    executeCommand c
+    modifiedCode <- getDocumentEdit doc
+    liftIO $ expectedCode @=? modifiedCode
+  in
+  testGroup "add signature"
+    [ testGroup "with warnings enabled"
+      [ sigSession True "abc = True"             "abc :: Bool"
+      , sigSession True "foo a b = a + b"        "foo :: Num a => a -> a -> a"
+      , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
+      , sigSession True "(!!!) a b = a > b"      "(!!!) :: Ord a => a -> a -> Bool"
+      , sigSession True "a >>>> b = a + b"       "(>>>>) :: Num a => a -> a -> a"
+      , sigSession True "a `haha` b = a b"       "haha :: (t1 -> t2) -> t1 -> t2"
+      ]
+    , testGroup "with warnings disabled"
+      [ sigSession False "abc = True"             "abc :: Bool"
+      , sigSession False "foo a b = a + b"        "foo :: Num a => a -> a -> a"
+      , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
+      , sigSession False "(!!!) a b = a > b"      "(!!!) :: Ord a => a -> a -> Bool"
+      , sigSession False "a >>>> b = a + b"       "(>>>>) :: Num a => a -> a -> a"
+      , sigSession False "a `haha` b = a b"       "haha :: (t1 -> t2) -> t1 -> t2"
+      ]
+    ]
 
 findDefinitionAndHoverTests :: TestTree
 findDefinitionAndHoverTests = let