Skip to content

Commit 4c7e56a

Browse files
janvogtJan Vogt
janvogt
and
Jan Vogt
authored
Start using structured diagnostics for missing signatures (#4625)
* Fix nix dev environment on aarch64-darwin. * Add hls to nix dev environment * Add prisms for GHC structured diagnostics * Provide GHC structured diagnostics in GhcideCodeActions * Use GHC structured diagnostics for missing signatures * Fix ranges in completion tests How did they ever work? --------- Co-authored-by: Jan Vogt <jan.vogt+csenv@findeck.de>
1 parent 8fc5a79 commit 4c7e56a

File tree

6 files changed

+101
-60
lines changed

6 files changed

+101
-60
lines changed

‎flake.lock‎

Lines changed: 4 additions & 4 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎flake.nix‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,9 @@
22
description = "haskell-language-server development flake";
33

44
inputs = {
5-
nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
5+
# Don't use nixpkgs-unstable as aarch64-darwin is currently broken there.
6+
# Check again, when https://github.com/NixOS/nixpkgs/pull/414242 is resolved.
7+
nixpkgs.url = "github:NixOS/nixpkgs/c742ae7908a82c9bf23ce27bfca92a00e9bcd541";
68
flake-utils.url = "github:numtide/flake-utils";
79
# For default.nix
810
flake-compat = {
@@ -66,6 +68,7 @@
6668
buildInputs = [
6769
# Compiler toolchain
6870
hpkgs.ghc
71+
hpkgs.haskell-language-server
6972
pkgs.haskellPackages.cabal-install
7073
# Dependencies needed to build some parts of Hackage
7174
gmp zlib ncurses

‎ghcide/src/Development/IDE/GHC/Compat/Error.hs‎

Lines changed: 18 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,9 +19,11 @@ module Development.IDE.GHC.Compat.Error (
1919
Diagnostic(..),
2020
-- * Prisms for error selection
2121
_TcRnMessage,
22+
_TcRnMessageWithCtx,
2223
_GhcPsMessage,
2324
_GhcDsMessage,
2425
_GhcDriverMessage,
26+
_TcRnMissingSignature,
2527
) where
2628

2729
import Control.Lens
@@ -30,8 +32,20 @@ import GHC.HsToCore.Errors.Types
3032
import GHC.Tc.Errors.Types
3133
import GHC.Types.Error
3234

33-
_TcRnMessage :: Prism' GhcMessage TcRnMessage
34-
_TcRnMessage = prism' GhcTcRnMessage (\case
35+
-- | Some 'TcRnMessage's are nested in other constructors for additional context.
36+
-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.
37+
-- However, in most occasions you don't need the additional context and you just want
38+
-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors,
39+
-- until there are no more constructors with additional context.
40+
--
41+
-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always
42+
-- strip it later using @'stripTcRnMessageContext'@.
43+
--
44+
_TcRnMessage :: Fold GhcMessage TcRnMessage
45+
_TcRnMessage = _TcRnMessageWithCtx . to stripTcRnMessageContext
46+
47+
_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage
48+
_TcRnMessageWithCtx = prism' GhcTcRnMessage (\case
3549
GhcTcRnMessage tcRnMsg -> Just tcRnMsg
3650
_ -> Nothing)
3751

@@ -66,3 +80,5 @@ stripTcRnMessageContext = \case
6680

6781
msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
6882
msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )
83+
84+
makePrisms ''TcRnMessage

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs‎

Lines changed: 23 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ module Development.IDE.Plugin.TypeLenses (
1616

1717
import Control.Concurrent.STM.Stats (atomically)
1818
import Control.DeepSeq (rwhnf)
19-
import Control.Lens ((?~))
19+
import Control.Lens (to, (?~), (^?))
2020
import Control.Monad (mzero)
2121
import Control.Monad.Extra (whenMaybe)
2222
import Control.Monad.IO.Class (MonadIO (liftIO))
@@ -25,13 +25,17 @@ import Data.Aeson.Types (toJSON)
2525
import qualified Data.Aeson.Types as A
2626
import Data.List (find)
2727
import qualified Data.Map as Map
28-
import Data.Maybe (catMaybes, maybeToList)
28+
import Data.Maybe (catMaybes, isJust,
29+
maybeToList)
2930
import qualified Data.Text as T
3031
import Development.IDE (FileDiagnostic (..),
3132
GhcSession (..),
3233
HscEnvEq (hscEnv),
3334
RuleResult, Rules, Uri,
34-
define, srcSpanToRange,
35+
_SomeStructuredMessage,
36+
define,
37+
fdStructuredMessageL,
38+
srcSpanToRange,
3539
usePropertyAction)
3640
import Development.IDE.Core.Compile (TcModuleResult (..))
3741
import Development.IDE.Core.PluginUtils
@@ -45,6 +49,10 @@ import Development.IDE.Core.Shake (getHiddenDiagnostics,
4549
use)
4650
import qualified Development.IDE.Core.Shake as Shake
4751
import Development.IDE.GHC.Compat
52+
import Development.IDE.GHC.Compat.Error (_TcRnMessage,
53+
_TcRnMissingSignature,
54+
msgEnvelopeErrorL,
55+
stripTcRnMessageContext)
4856
import Development.IDE.GHC.Util (printName)
4957
import Development.IDE.Graph.Classes
5058
import Development.IDE.Types.Location (Position (Position, _line),
@@ -129,9 +137,9 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif
129137
-- dummy type to make sure HLS resolves our lens
130138
[ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve)
131139
| diag <- diags
132-
, let lspDiag@Diagnostic {_range} = fdLspDiagnostic diag
140+
, let Diagnostic {_range} = fdLspDiagnostic diag
133141
, fdFilePath diag == nfp
134-
, isGlobalDiagnostic lspDiag]
142+
, isGlobalDiagnostic diag]
135143
-- The second option is to generate lenses from the GlobalBindingTypeSig
136144
-- rule. This is the only type that needs to have the range adjusted
137145
-- with PositionMapping.
@@ -200,22 +208,27 @@ commandHandler _ideState _ wedit = do
200208
pure $ InR Null
201209

202210
--------------------------------------------------------------------------------
203-
suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)]
211+
suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> [(T.Text, TextEdit)]
204212
suggestSignature isQuickFix mGblSigs diag =
205213
maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag)
206214

207215
-- The suggestGlobalSignature is separated into two functions. The main function
208216
-- works with a diagnostic, which then calls the secondary function with
209217
-- whatever pieces of the diagnostic it needs. This allows the resolve function,
210218
-- which no longer has the Diagnostic, to still call the secondary functions.
211-
suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit)
212-
suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range}
219+
suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> Maybe (T.Text, TextEdit)
220+
suggestGlobalSignature isQuickFix mGblSigs diag@FileDiagnostic {fdLspDiagnostic = Diagnostic {_range}}
213221
| isGlobalDiagnostic diag =
214222
suggestGlobalSignature' isQuickFix mGblSigs Nothing _range
215223
| otherwise = Nothing
216224

217-
isGlobalDiagnostic :: Diagnostic -> Bool
218-
isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)
225+
isGlobalDiagnostic :: FileDiagnostic -> Bool
226+
isGlobalDiagnostic diag = diag ^? fdStructuredMessageL
227+
. _SomeStructuredMessage
228+
. msgEnvelopeErrorL
229+
. _TcRnMessage
230+
. _TcRnMissingSignature
231+
& isJust
219232

220233
-- If a PositionMapping is supplied, this function will call
221234
-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location.

‎plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs‎

Lines changed: 43 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -22,11 +22,13 @@ import Data.Either (fromRight,
2222
import Data.Functor ((<&>))
2323
import Data.IORef.Extra
2424
import qualified Data.Map as Map
25-
import Data.Maybe (fromMaybe)
25+
import Data.Maybe (fromMaybe,
26+
maybeToList)
2627
import qualified Data.Text as T
2728
import qualified Data.Text.Utf16.Rope.Mixed as Rope
2829
import Development.IDE hiding
2930
(pluginHandlers)
31+
import Development.IDE.Core.PluginUtils (activeDiagnosticsInRange)
3032
import Development.IDE.Core.Shake
3133
import Development.IDE.GHC.Compat
3234
import Development.IDE.GHC.ExactPrint
@@ -53,38 +55,42 @@ type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCo
5355
-------------------------------------------------------------------------------------------------
5456

5557
runGhcideCodeAction :: IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> HandlerM Config GhcideCodeActionResult
56-
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do
57-
let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
58-
runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key
59-
caaGhcSession <- onceIO $ runRule GhcSession
60-
caaExportsMap <-
61-
onceIO $
62-
caaGhcSession >>= \case
63-
Just env -> do
64-
pkgExports <- envPackageExports env
65-
localExports <- readTVarIO (exportsMap $ shakeExtras state)
66-
pure $ localExports <> pkgExports
67-
_ -> pure mempty
68-
caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions
69-
caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
70-
caaContents <-
71-
onceIO $
72-
runRule GetFileContents <&> \case
73-
Just (_, mbContents) -> fmap Rope.toText mbContents
74-
Nothing -> Nothing
75-
caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
76-
caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
77-
caaTmr <- onceIO $ runRule TypeCheck
78-
caaHar <- onceIO $ runRule GetHieAst
79-
caaBindings <- onceIO $ runRule GetBindings
80-
caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
81-
results <- liftIO $
82-
sequence
83-
[ runReaderT (runExceptT codeAction) CodeActionArgs {..}
84-
| caaDiagnostic <- diags
85-
]
86-
let (_errs, successes) = partitionEithers results
87-
pure $ concat successes
58+
runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range _) codeAction
59+
| Just nfp <- toNormalizedFilePath' <$> uriToFilePath uri = do
60+
let runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure (Just nfp)) >>= MaybeT . use key
61+
caaGhcSession <- onceIO $ runRule GhcSession
62+
caaExportsMap <-
63+
onceIO $
64+
caaGhcSession >>= \case
65+
Just env -> do
66+
pkgExports <- envPackageExports env
67+
localExports <- readTVarIO (exportsMap $ shakeExtras state)
68+
pure $ localExports <> pkgExports
69+
_ -> pure mempty
70+
caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions
71+
caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
72+
caaContents <-
73+
onceIO $
74+
runRule GetFileContents <&> \case
75+
Just (_, mbContents) -> fmap Rope.toText mbContents
76+
Nothing -> Nothing
77+
caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
78+
caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
79+
caaTmr <- onceIO $ runRule TypeCheck
80+
caaHar <- onceIO $ runRule GetHieAst
81+
caaBindings <- onceIO $ runRule GetBindings
82+
caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
83+
diags <- concat . maybeToList <$> activeDiagnosticsInRange (shakeExtras state) nfp _range
84+
results <- liftIO $
85+
sequence
86+
[
87+
runReaderT (runExceptT codeAction) CodeActionArgs {..}
88+
| caaDiagnostic <- diags
89+
]
90+
let (_errs, successes) = partitionEithers results
91+
pure $ concat successes
92+
| otherwise = pure []
93+
8894

8995
mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
9096
mkCA title kind isPreferred diags edit =
@@ -145,7 +151,7 @@ data CodeActionArgs = CodeActionArgs
145151
caaHar :: IO (Maybe HieAstResult),
146152
caaBindings :: IO (Maybe Bindings),
147153
caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult),
148-
caaDiagnostic :: Diagnostic
154+
caaDiagnostic :: FileDiagnostic
149155
}
150156

151157
-- | There's no concurrency in each provider,
@@ -223,6 +229,9 @@ instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where
223229
toCodeAction = toCodeAction3 caaIdeOptions
224230

225231
instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where
232+
toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f (fdLspDiagnostic x)
233+
234+
instance ToCodeAction r => ToCodeAction (FileDiagnostic -> r) where
226235
toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x
227236

228237
instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where

‎plugins/hls-refactor-plugin/test/Main.hs‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1157,7 +1157,7 @@ extendImportTests = testGroup "extend import actions"
11571157
, "x :: (:~:) [] []"
11581158
, "x = Refl"
11591159
])
1160-
(Range (Position 3 17) (Position 3 18))
1160+
(Range (Position 3 4) (Position 3 8))
11611161
[ "Add (:~:)(..) to the import list of Data.Type.Equality"
11621162
, "Add type (:~:)(Refl) to the import list of Data.Type.Equality"]
11631163
(T.unlines
@@ -1221,7 +1221,7 @@ extendImportTests = testGroup "extend import actions"
12211221
, "import ModuleA as A (stuffB)"
12221222
, "main = print (stuffB .* stuffB)"
12231223
])
1224-
(Range (Position 2 17) (Position 2 18))
1224+
(Range (Position 2 22) (Position 2 24))
12251225
["Add (.*) to the import list of ModuleA"]
12261226
(T.unlines
12271227
[ "module ModuleB where"
@@ -1235,7 +1235,7 @@ extendImportTests = testGroup "extend import actions"
12351235
, "import Data.List.NonEmpty (fromList)"
12361236
, "main = case (fromList []) of _ :| _ -> pure ()"
12371237
])
1238-
(Range (Position 2 5) (Position 2 6))
1238+
(Range (Position 2 31) (Position 2 33))
12391239
[ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"
12401240
, "Add NonEmpty(..) to the import list of Data.List.NonEmpty"
12411241
]
@@ -1252,7 +1252,7 @@ extendImportTests = testGroup "extend import actions"
12521252
, "import Data.Maybe (catMaybes)"
12531253
, "x = Just 10"
12541254
])
1255-
(Range (Position 3 5) (Position 2 6))
1255+
(Range (Position 3 4) (Position 3 8))
12561256
[ "Add Maybe(Just) to the import list of Data.Maybe"
12571257
, "Add Maybe(..) to the import list of Data.Maybe"
12581258
]
@@ -1484,7 +1484,7 @@ extendImportTests = testGroup "extend import actions"
14841484
, "import ModuleA ()"
14851485
, "foo = bar"
14861486
])
1487-
(Range (Position 3 17) (Position 3 18))
1487+
(Range (Position 3 6) (Position 3 9))
14881488
["Add bar to the import list of ModuleA",
14891489
"Add bar to the import list of ModuleB"]
14901490
(T.unlines
@@ -1501,7 +1501,7 @@ extendImportTests = testGroup "extend import actions"
15011501
, "x :: (:~:) [] []"
15021502
, "x = Refl"
15031503
])
1504-
(Range (Position 3 17) (Position 3 18))
1504+
(Range (Position 3 4) (Position 3 8))
15051505
[ "Add type (:~:)(Refl) to the import list of Data.Type.Equality"
15061506
, "Add (:~:)(..) to the import list of Data.Type.Equality"]
15071507
(T.unlines
@@ -2425,7 +2425,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
24252425
docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)
24262426
_ <- waitForDiagnostics
24272427
action <- pickActionWithTitle "Define select :: Int -> Bool"
2428-
=<< getCodeActions docB (R 1 0 0 50)
2428+
=<< getCodeActions docB (R 1 8 1 14)
24292429
executeCodeAction action
24302430
contentAfterAction <- documentContents docB
24312431
liftIO $ contentAfterAction @?= T.unlines expected
@@ -2449,7 +2449,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
24492449
docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)
24502450
_ <- waitForDiagnostics
24512451
action <- pickActionWithTitle "Define select :: Int -> Bool"
2452-
=<< getCodeActions docB (R 1 0 0 50)
2452+
=<< getCodeActions docB (R 1 8 1 14)
24532453
executeCodeAction action
24542454
contentAfterAction <- documentContents docB
24552455
liftIO $ contentAfterAction @?= T.unlines expected
@@ -2750,7 +2750,7 @@ fixConstructorImportTests = testGroup "fix import actions"
27502750
[ "module ModuleB where"
27512751
, "import ModuleA(Constructor)"
27522752
])
2753-
(Range (Position 1 10) (Position 1 11))
2753+
(Range (Position 1 15) (Position 1 26))
27542754
"Fix import of A(Constructor)"
27552755
(T.unlines
27562756
[ "module ModuleB where"

0 commit comments

Comments
 (0)