1b1c585 · ghcide · git.iko.soy

git.iko.soy/ghcide

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

commit1b1c58518dbc4171e88cd0c058a06d61d4fa9258 authorAlejandro Serrano <trupill@gmail.com> dateTue 17 Dec 2019, 15:13 (7 years ago) parente863912

8 files changed+118−45

compare with master

unifiedsplit

exe/Main.hs+1−1 src/Development/IDE/Core/Compile.hs+10−18 src/Development/IDE/Core/Rules.hs+1−1 src/Development/IDE/Core/Shake.hs+26−8 src/Development/IDE/GHC/Error.hs+1−1 src/Development/IDE/LSP/CodeAction.hs+2−1 src/Development/IDE/Types/Diagnostics.hs+20−3 test/exe/Main.hs+57−12

exe/Main.hs+1−1

@@ -150,7 +150,7 @@ kick = do

150150showEvent :: Lock -> FromServerMessage -> IO ()

151151showEvent _ (EventFileDiagnostics _ []) = return ()

152152showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

153− withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags

153+ withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags

154154showEvent lock e = withLock lock $ print e

155155

156156

src/Development/IDE/Core/Compile.hs+10−18

@@ -108,13 +108,7 @@ typecheckModule (IdeDefer defer) packageState deps pm =

108108 GHC.typecheckModule $ enableTopLevelWarnings

109109 $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}

110110 tcm2 <- mkTcModuleResult tcm

111− let errorPipeline = unDefer

112− . (if wopt Opt_WarnMissingSignatures dflags

113− then id

114− else degradeError Opt_WarnMissingSignatures)

115− . (if wopt Opt_WarnMissingLocalSignatures dflags

116− then id

117− else degradeError Opt_WarnMissingLocalSignatures)

111+ let errorPipeline = unDefer . hideDiag dflags

118112 return (map errorPipeline warnings, tcm2)

119113

120114initPlugins :: GhcMonad m => ModSummary -> m ModSummary

@@ -182,7 +176,9 @@ demoteTypeErrorsToWarnings =

182176enableTopLevelWarnings :: ParsedModule -> ParsedModule

183177enableTopLevelWarnings =

184178 (update_pm_mod_summary . update_hspp_opts)

185− ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))

179+ (`wopt_set` Opt_WarnMissingSignatures)

180+ -- the line below would show also warnings for let bindings without signature

181+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))

186182

187183update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

188184update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

@@ -197,20 +193,16 @@ unDefer (Reason Opt_WarnTypedHoles , fd) = upgradeWarningToError

197193unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd

198194unDefer ( _ , fd) = fd

199195

200−degradeError :: WarningFlag -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

201−degradeError f (Reason f', fd)

202− | f == f' = (Reason f', degradeWarningToError fd)

203−degradeError _ wfd = wfd

204−

205196upgradeWarningToError :: FileDiagnostic -> FileDiagnostic

206−upgradeWarningToError (nfp, fd) =

207− (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where

197+upgradeWarningToError (nfp, sh, fd) =

198+ (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where

208199 warn2err :: T.Text -> T.Text

209200 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"

210201

211−degradeWarningToError :: FileDiagnostic -> FileDiagnostic

212−degradeWarningToError (nfp, fd) =

213− (nfp, fd{_severity = Just DsInfo})

202+hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

203+hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

204+ | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

205+hideDiag _originalFlags t = t

214206

215207addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

216208addRelativeImport fp modu dflags = dflags

src/Development/IDE/Core/Rules.hs+1−1

@@ -229,7 +229,7 @@ reportImportCyclesRule =

229229 where cycleErrorInFile f (PartOfCycle imp fs)

230230 | f `elem` fs = Just (imp, fs)

231231 cycleErrorInFile _ _ = Nothing

232− toDiag imp mods = (fp ,) $ Diagnostic

232+ toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic

233233 { _range = (_range :: Location -> Range) loc

234234 , _severity = Just DsError

235235 , _source = Just "Import cycle detection"

src/Development/IDE/Core/Shake.hs+26−8

@@ -28,6 +28,7 @@ module Development.IDE.Core.Shake(

2828 use_, useNoFile_, uses_,

2929 define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,

3030 getDiagnostics, unsafeClearDiagnostics,

31+ getHiddenDiagnostics,

3132 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,

3233 garbageCollect,

3334 setPriority,

@@ -93,6 +94,7 @@ data ShakeExtras = ShakeExtras

9394 ,globals :: Var (HMap.HashMap TypeRep Dynamic)

9495 ,state :: Var Values

9596 ,diagnostics :: Var DiagnosticStore

97+ ,hiddenDiagnostics :: Var DiagnosticStore

9698 ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])

9799 -- ^ This represents the set of diagnostics that we have published.

98100 -- Due to debouncing not every change might get published.

@@ -289,6 +291,7 @@ shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgr

289291 globals <- newVar HMap.empty

290292 state <- newVar HMap.empty

291293 diagnostics <- newVar mempty

294+ hiddenDiagnostics <- newVar mempty

292295 publishedDiagnostics <- newVar mempty

293296 debouncer <- newDebouncer

294297 positionMapping <- newVar Map.empty

@@ -400,6 +403,11 @@ getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

400403 val <- readVar diagnostics

401404 return $ getAllDiagnostics val

402405

406+getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]

407+getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do

408+ val <- readVar hiddenDiagnostics

409+ return $ getAllDiagnostics val

410+

403411-- | FIXME: This function is temporary! Only required because the files of interest doesn't work

404412unsafeClearDiagnostics :: IdeState -> IO ()

405413unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =

@@ -408,12 +416,13 @@ unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =

408416-- | Clear the results for all files that do not match the given predicate.

409417garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()

410418garbageCollect keep = do

411− ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras

419+ ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras

412420 liftIO $

413421 do newState <- modifyVar state $ \values -> do

414422 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values

415423 return $! dupe values

416424 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags

425+ modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags

417426 modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags

418427 let versionsForFile =

419428 Map.fromListWith Set.union $

@@ -528,7 +537,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

528537 Failed -> (toShakeValue ShakeResult bs, Failed)

529538 Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

530539 liftIO $ setValues state key file res

531− updateFileDiagnostics file (Key key) extras $ map snd diags

540+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

532541 let eq = case (bs, fmap decodeShakeValue old) of

533542 (ShakeResult a, Just (ShakeResult b)) -> a == b

534543 (ShakeStale a, Just (ShakeStale b)) -> a == b

@@ -589,7 +598,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

589598 case mbOld of

590599 Nothing -> do

591600 (diags, mbHash) <- runAct

592− updateFileDiagnostics file (Key key) extras $ map snd diags

601+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

593602 pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)

594603 Just old -> do

595604 current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")

@@ -600,7 +609,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

600609 pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)

601610 else do

602611 (diags, mbHash) <- runAct

603− updateFileDiagnostics file (Key key) extras $ map snd diags

612+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

604613 let change

605614 | mbHash == Just old = ChangedRecomputeSame

606615 | otherwise = ChangedRecomputeDiff

@@ -656,21 +665,30 @@ updateFileDiagnostics ::

656665 NormalizedFilePath

657666 -> Key

658667 -> ShakeExtras

659− -> [Diagnostic] -- ^ current results

668+ -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

660669 -> Action ()

661−updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

670+updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

662671 modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

672+ let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

663673 mask_ $ do

664674 -- Mask async exceptions to ensure that updated diagnostics are always

665675 -- published. Otherwise, we might never publish certain diagnostics if

666676 -- an exception strikes between modifyVar but before

667677 -- publishDiagnosticsNotification.

668678 newDiags <- modifyVar diagnostics $ \old -> do

669− let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old

679+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

680+ (T.pack $ show k) (map snd currentShown) old

670681 let newDiags = getFileDiagnostics fp newDiagsStore

671682 _ <- evaluate newDiagsStore

672683 _ <- evaluate newDiags

673684 pure $! (newDiagsStore, newDiags)

685+ modifyVar_ hiddenDiagnostics $ \old -> do

686+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

687+ (T.pack $ show k) (map snd currentHidden) old

688+ let newDiags = getFileDiagnostics fp newDiagsStore

689+ _ <- evaluate newDiagsStore

690+ _ <- evaluate newDiags

691+ return newDiagsStore

674692 let uri = filePathToUri' fp

675693 let delay = if null newDiags then 0.1 else 0

676694 registerEvent debouncer delay uri $ do

@@ -751,7 +769,7 @@ getAllDiagnostics ::

751769 DiagnosticStore ->

752770 [FileDiagnostic]

753771getAllDiagnostics =

754− concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList

772+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList

755773

756774getFileDiagnostics ::

757775 NormalizedFilePath ->

src/Development/IDE/GHC/Error.hs+1−1

@@ -34,7 +34,7 @@ import qualified Outputable as Out

3434

3535

3636diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic

37−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,)

37+diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)

3838 Diagnostic

3939 { _range = srcSpanToRange loc

4040 , _severity = Just sev

src/Development/IDE/LSP/CodeAction.hs+2−1

@@ -59,9 +59,10 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}

5959 Just (toNormalizedFilePath -> filePath) -> do

6060 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

6161 diag <- getDiagnostics ideState

62+ hDiag <- getHiddenDiagnostics ideState

6263 pure $ List

6364 [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

64− | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag

65+ | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag

6566 , dFile == filePath

6667 , (title, tedit) <- suggestSignature False dDiag

6768 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

src/Development/IDE/Types/Diagnostics.hs+20−3

@@ -4,6 +4,7 @@

55module Development.IDE.Types.Diagnostics (

66 LSP.Diagnostic(..),

7+ ShowDiagnostic(..),

78 FileDiagnostic,

89 LSP.DiagnosticSeverity(..),

910 DiagnosticStore,

@@ -13,6 +14,7 @@ module Development.IDE.Types.Diagnostics (

1314 showDiagnosticsColored,

1415 ) where

1516

17+import Control.DeepSeq

1618import Data.Maybe as Maybe

1719import qualified Data.Text as T

1820import Data.Text.Prettyprint.Doc

@@ -30,7 +32,7 @@ import Development.IDE.Types.Location

3032

3133

3234ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

33−ideErrorText fp msg = (fp, LSP.Diagnostic {

35+ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {

3436 _range = noRange,

3537 _severity = Just LSP.DsError,

3638 _code = Nothing,

@@ -39,6 +41,20 @@ ideErrorText fp msg = (fp, LSP.Diagnostic {

3941 _relatedInformation = Nothing

4042 })

4143

44+-- | Defines whether a particular diagnostic should be reported

45+-- back to the user.

46+--

47+-- One important use case is "missing signature" code lenses,

48+-- for which we need to enable the corresponding warning during

49+-- type checking. However, we do not want to show the warning

50+-- unless the programmer asks for it (#261).

51+data ShowDiagnostic

52+ = ShowDiag -- ^ Report back to the user

53+ | HideDiag -- ^ Hide from user

54+ deriving (Eq, Ord, Show)

55+

56+instance NFData ShowDiagnostic where

57+ rnf = rwhnf

4258

4359-- | Human readable diagnostics for a specific file.

4460--

@@ -46,7 +62,7 @@ ideErrorText fp msg = (fp, LSP.Diagnostic {

4662-- along with the related source location so that we can display the error

4763-- on either the console or in the IDE at the right source location.

4864--

49−type FileDiagnostic = (NormalizedFilePath, Diagnostic)

65+type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)

5066

5167prettyRange :: Range -> Doc Terminal.AnsiStyle

5268prettyRange Range{..} = f _start <> "-" <> f _end

@@ -66,9 +82,10 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle

6682prettyDiagnostics = vcat . map prettyDiagnostic

6783

6884prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle

69−prettyDiagnostic (fp, LSP.Diagnostic{..}) =

85+prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =

7086 vcat

7187 [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)

88+ , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes"

7289 , slabel_ "Range: " $ prettyRange _range

7390 , slabel_ "Source: " $ pretty _source

7491 , slabel_ "Severity:" $ pretty $ show sev

test/exe/Main.hs+57−12

@@ -39,6 +39,7 @@ main = defaultMain $ testGroup "HIE"

3939 , initializeResponseTests

4040 , diagnosticTests

4141 , codeActionTests

42+ , codeLensesTests

4243 , findDefinitionAndHoverTests

4344 , pluginTests

4445 , thTests

@@ -385,6 +386,11 @@ codeActionTests = testGroup "code actions"

385386 , addSigActionTests

386387 ]

387388

389+codeLensesTests :: TestTree

390+codeLensesTests = testGroup "code lenses"

391+ [ addSigLensesTests

392+ ]

393+

388394renameActionTests :: TestTree

389395renameActionTests = testGroup "rename actions"

390396 [ testSession "change to local variable name" $ do

@@ -673,14 +679,14 @@ fillTypedHoleTests = let

673679

674680addSigActionTests :: TestTree

675681addSigActionTests = let

676− header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"

677− , "module Sigs where"]

678− before def = T.unlines [header, def]

679− after' def sig = T.unlines [header, sig, def]

682+ header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"

683+ moduleH = "module Sigs where"

684+ before def = T.unlines [header, moduleH, def]

685+ after' def sig = T.unlines [header, moduleH, sig, def]

680686

681687 def >:: sig = testSession (T.unpack def) $ do

682688 let originalCode = before def

683− let expectedCode = after' def sig

689+ let expectedCode = after' def sig

684690 doc <- openDoc' "Sigs.hs" "haskell" originalCode

685691 _ <- waitForDiagnostics

686692 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

@@ -690,13 +696,52 @@ addSigActionTests = let

690696 liftIO $ expectedCode @=? modifiedCode

691697 in

692698 testGroup "add signature"

693− [ "abc = True" >:: "abc :: Bool"

694− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

695− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

696− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

697− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

698− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

699− ]

699+ [ "abc = True" >:: "abc :: Bool"

700+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

701+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

702+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

703+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

704+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

705+ ]

706+

707+addSigLensesTests :: TestTree

708+addSigLensesTests = let

709+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"

710+ notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

711+ moduleH = "module Sigs where"

712+ other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

713+ before withMissing def

714+ = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

715+ after' withMissing def sig

716+ = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]

717+

718+ sigSession withMissing def sig = testSession (T.unpack def) $ do

719+ let originalCode = before withMissing def

720+ let expectedCode = after' withMissing def sig

721+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

722+ [CodeLens {_command = Just c}] <- getCodeLenses doc

723+ executeCommand c

724+ modifiedCode <- getDocumentEdit doc

725+ liftIO $ expectedCode @=? modifiedCode

726+ in

727+ testGroup "add signature"

728+ [ testGroup "with warnings enabled"

729+ [ sigSession True "abc = True" "abc :: Bool"

730+ , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"

731+ , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

732+ , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

733+ , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

734+ , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

735+ ]

736+ , testGroup "with warnings disabled"

737+ [ sigSession False "abc = True" "abc :: Bool"

738+ , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"

739+ , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

740+ , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

741+ , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

742+ , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

743+ ]

744+ ]

700745

701746findDefinitionAndHoverTests :: TestTree

702747findDefinitionAndHoverTests = let