Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 4c7e56a

Browse files
janvogtJan Vogt
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 26))
1255+
(Range (Position 3 4) (Position 38))
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 0050)
2428+
=<< getCodeActions docB (R 1 8114)
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 0050)
2452+
=<< getCodeActions docB (R 1 8114)
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)

AltStyle によって変換されたページ (->オリジナル) /