Start using structured diagnostics for missing signatures

flake.nix

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

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

@@ -19,9 +19,11 @@ module Development.IDE.GHC.Compat.Error (
   Diagnostic(..),
   -- * Prisms for error selection
   _TcRnMessage,
+  _TcRnMessageWithCtx,
   _GhcPsMessage,
   _GhcDsMessage,
   _GhcDriverMessage,
+  _TcRnMissingSignature,
   ) where
 
 import           Control.Lens
@@ -30,8 +32,20 @@ import           GHC.HsToCore.Errors.Types
 import           GHC.Tc.Errors.Types
 import           GHC.Types.Error
 
-_TcRnMessage :: Prism' GhcMessage TcRnMessage
-_TcRnMessage = prism' GhcTcRnMessage (\case
+-- | Some 'TcRnMessage's are nested in other constructors for additional context.
+-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.
+-- However, in most occasions you don't need the additional context and you just want
+-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors,
+-- until there are no more constructors with additional context.
+--
+-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always
+-- strip it later using @'stripTcRnMessageContext'@.
+--
+_TcRnMessage :: Fold GhcMessage TcRnMessage
+_TcRnMessage = _TcRnMessageWithCtx . to stripTcRnMessageContext
+
+_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage
+_TcRnMessageWithCtx = prism' GhcTcRnMessage (\case
   GhcTcRnMessage tcRnMsg -> Just tcRnMsg
   _ -> Nothing)
 
@@ -66,3 +80,5 @@ stripTcRnMessageContext = \case
 
 msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
 msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )
+
+makePrisms ''TcRnMessage

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

@@ -16,7 +16,7 @@ module Development.IDE.Plugin.TypeLenses (
 
 import           Control.Concurrent.STM.Stats         (atomically)
 import           Control.DeepSeq                      (rwhnf)
-import           Control.Lens                         ((?~))
+import           Control.Lens                         (to, (?~), (^?))
 import           Control.Monad                        (mzero)
 import           Control.Monad.Extra                  (whenMaybe)
 import           Control.Monad.IO.Class               (MonadIO (liftIO))
@@ -25,13 +25,17 @@ import           Data.Aeson.Types                     (toJSON)
 import qualified Data.Aeson.Types                     as A
 import           Data.List                            (find)
 import qualified Data.Map                             as Map
-import           Data.Maybe                           (catMaybes, maybeToList)
+import           Data.Maybe                           (catMaybes, isJust,
+                                                       maybeToList)
 import qualified Data.Text                            as T
 import           Development.IDE                      (FileDiagnostic (..),
                                                        GhcSession (..),
                                                        HscEnvEq (hscEnv),
                                                        RuleResult, Rules, Uri,
-                                                       define, srcSpanToRange,
+                                                       _SomeStructuredMessage,
+                                                       define,
+                                                       fdStructuredMessageL,
+                                                       srcSpanToRange,
                                                        usePropertyAction)
 import           Development.IDE.Core.Compile         (TcModuleResult (..))
 import           Development.IDE.Core.PluginUtils
@@ -45,6 +49,10 @@ import           Development.IDE.Core.Shake           (getHiddenDiagnostics,
                                                        use)
 import qualified Development.IDE.Core.Shake           as Shake
 import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Compat.Error     (_TcRnMessage,
+                                                       _TcRnMissingSignature,
+                                                       msgEnvelopeErrorL,
+                                                       stripTcRnMessageContext)
 import           Development.IDE.GHC.Util             (printName)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Types.Location       (Position (Position, _line),
@@ -129,9 +137,9 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif
           -- dummy type to make sure HLS resolves our lens
           [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve)
             | diag <- diags
-            , let lspDiag@Diagnostic {_range} = fdLspDiagnostic diag
+            , let Diagnostic {_range} = fdLspDiagnostic diag
             , fdFilePath diag == nfp
-            , isGlobalDiagnostic lspDiag]
+            , isGlobalDiagnostic diag]
         -- The second option is to generate lenses from the GlobalBindingTypeSig
         -- rule. This is the only type that needs to have the range adjusted
         -- with PositionMapping.
@@ -200,22 +208,27 @@ commandHandler _ideState _ wedit = do
   pure $ InR Null
 
 --------------------------------------------------------------------------------
-suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)]
+suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> [(T.Text, TextEdit)]
 suggestSignature isQuickFix mGblSigs diag =
   maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag)
 
 -- The suggestGlobalSignature is separated into two functions. The main function
 -- works with a diagnostic, which then calls the secondary function with
 -- whatever pieces of the diagnostic it needs. This allows the resolve function,
 -- which no longer has the Diagnostic, to still call the secondary functions.
-suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit)
-suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range}
+suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> Maybe (T.Text, TextEdit)
+suggestGlobalSignature isQuickFix mGblSigs diag@FileDiagnostic {fdLspDiagnostic = Diagnostic {_range}}
   | isGlobalDiagnostic diag =
     suggestGlobalSignature' isQuickFix mGblSigs Nothing _range
   | otherwise = Nothing
 
-isGlobalDiagnostic :: Diagnostic -> Bool
-isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)
+isGlobalDiagnostic :: FileDiagnostic -> Bool
+isGlobalDiagnostic diag = diag ^? fdStructuredMessageL
+                                  . _SomeStructuredMessage
+                                  . msgEnvelopeErrorL
+                                  .  _TcRnMessage
+                                  . _TcRnMissingSignature
+                                & isJust
 
 -- If a PositionMapping is supplied, this function will call
 -- gblBindingTypeSigToEdit with it to create a TextEdit in the right location.

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

@@ -22,11 +22,13 @@ import           Data.Either                                  (fromRight,
 import           Data.Functor                                 ((<&>))
 import           Data.IORef.Extra
 import qualified Data.Map                                     as Map
-import           Data.Maybe                                   (fromMaybe)
+import           Data.Maybe                                   (fromMaybe,
+                                                               maybeToList)
 import qualified Data.Text                                    as T
 import qualified Data.Text.Utf16.Rope.Mixed                   as Rope
 import           Development.IDE                              hiding
                                                               (pluginHandlers)
+import           Development.IDE.Core.PluginUtils             (activeDiagnosticsInRange)
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.ExactPrint
@@ -53,38 +55,42 @@ type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCo
 -------------------------------------------------------------------------------------------------
 
 runGhcideCodeAction :: IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> HandlerM Config GhcideCodeActionResult
-runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do
-  let mbFile = toNormalizedFilePath' <$> uriToFilePath uri
-      runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key
-  caaGhcSession <- onceIO $ runRule GhcSession
-  caaExportsMap <-
-    onceIO $
-      caaGhcSession >>= \case
-        Just env -> do
-          pkgExports <- envPackageExports env
-          localExports <- readTVarIO (exportsMap $ shakeExtras state)
-          pure $ localExports <> pkgExports
-        _ -> pure mempty
-  caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions
-  caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
-  caaContents <-
-    onceIO $
-      runRule GetFileContents <&> \case
-        Just (_, mbContents) -> fmap Rope.toText mbContents
-        Nothing       -> Nothing
-  caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
-  caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
-  caaTmr <- onceIO $ runRule TypeCheck
-  caaHar <- onceIO $ runRule GetHieAst
-  caaBindings <- onceIO $ runRule GetBindings
-  caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
-  results <- liftIO $
-      sequence
-        [ runReaderT (runExceptT codeAction) CodeActionArgs {..}
-          | caaDiagnostic <- diags
-        ]
-  let (_errs, successes) = partitionEithers results
-  pure $ concat successes
+runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range _) codeAction
+    | Just nfp <- toNormalizedFilePath' <$> uriToFilePath uri = do
+        let runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure (Just nfp)) >>= MaybeT . use key
+        caaGhcSession <- onceIO $ runRule GhcSession
+        caaExportsMap <-
+            onceIO $
+            caaGhcSession >>= \case
+                Just env -> do
+                    pkgExports <- envPackageExports env
+                    localExports <- readTVarIO (exportsMap $ shakeExtras state)
+                    pure $ localExports <> pkgExports
+                _ -> pure mempty
+        caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions
+        caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments
+        caaContents <-
+            onceIO $
+            runRule GetFileContents <&> \case
+                Just (_, mbContents) -> fmap Rope.toText mbContents
+                Nothing       -> Nothing
+        caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule
+        caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource
+        caaTmr <- onceIO $ runRule TypeCheck
+        caaHar <- onceIO $ runRule GetHieAst
+        caaBindings <- onceIO $ runRule GetBindings
+        caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs
+        diags <- concat . maybeToList <$> activeDiagnosticsInRange (shakeExtras state) nfp _range
+        results <- liftIO $
+            sequence
+                [
+                    runReaderT (runExceptT codeAction) CodeActionArgs {..}
+                        | caaDiagnostic <- diags
+                ]
+        let (_errs, successes) = partitionEithers results
+        pure $ concat successes
+    | otherwise = pure []
+
 
 mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)
 mkCA title kind isPreferred diags edit =
@@ -145,7 +151,7 @@ data CodeActionArgs = CodeActionArgs
     caaHar          :: IO (Maybe HieAstResult),
     caaBindings     :: IO (Maybe Bindings),
     caaGblSigs      :: IO (Maybe GlobalBindingTypeSigsResult),
-    caaDiagnostic   :: Diagnostic
+    caaDiagnostic   :: FileDiagnostic
   }
 
 -- | There's no concurrency in each provider,
@@ -223,6 +229,9 @@ instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where
   toCodeAction = toCodeAction3 caaIdeOptions
 
 instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where
+  toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f (fdLspDiagnostic x)
+
+instance ToCodeAction r => ToCodeAction (FileDiagnostic -> r) where
   toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . runExceptT . toCodeAction $ f x
 
 instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where

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

@@ -1157,7 +1157,7 @@ extendImportTests = testGroup "extend import actions"
                     , "x :: (:~:) [] []"
                     , "x = Refl"
                     ])
-            (Range (Position 3 17) (Position 3 18))
+            (Range (Position 3 4) (Position 3 8))
             [ "Add (:~:)(..) to the import list of Data.Type.Equality"
             , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"]
             (T.unlines
@@ -1221,7 +1221,7 @@ extendImportTests = testGroup "extend import actions"
                     , "import ModuleA as A (stuffB)"
                     , "main = print (stuffB .* stuffB)"
                     ])
-            (Range (Position 2 17) (Position 2 18))
+            (Range (Position 2 22) (Position 2 24))
             ["Add (.*) to the import list of ModuleA"]
             (T.unlines
                     [ "module ModuleB where"
@@ -1235,7 +1235,7 @@ extendImportTests = testGroup "extend import actions"
                     , "import Data.List.NonEmpty (fromList)"
                     , "main = case (fromList []) of _ :| _ -> pure ()"
                     ])
-            (Range (Position 2 5) (Position 2 6))
+            (Range (Position 2 31) (Position 2 33))
             [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"
             , "Add NonEmpty(..) to the import list of Data.List.NonEmpty"
             ]
@@ -1252,7 +1252,7 @@ extendImportTests = testGroup "extend import actions"
                     , "import Data.Maybe (catMaybes)"
                     , "x = Just 10"
                     ])
-            (Range (Position 3 5) (Position 2 6))
+            (Range (Position 3 4) (Position 3 8))
             [ "Add Maybe(Just) to the import list of Data.Maybe"
             , "Add Maybe(..) to the import list of Data.Maybe"
             ]
@@ -1484,7 +1484,7 @@ extendImportTests = testGroup "extend import actions"
                     , "import ModuleA ()"
                     , "foo = bar"
                     ])
-            (Range (Position 3 17) (Position 3 18))
+            (Range (Position 3 6) (Position 3 9))
             ["Add bar to the import list of ModuleA",
             "Add bar to the import list of ModuleB"]
             (T.unlines
@@ -1501,7 +1501,7 @@ extendImportTests = testGroup "extend import actions"
                     , "x :: (:~:) [] []"
                     , "x = Refl"
                     ])
-            (Range (Position 3 17) (Position 3 18))
+            (Range (Position 3 4) (Position 3 8))
             [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality"
             , "Add (:~:)(..) to the import list of Data.Type.Equality"]
             (T.unlines
@@ -2425,7 +2425,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
     docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)
     _ <- waitForDiagnostics
     action <- pickActionWithTitle "Define select :: Int -> Bool"
-            =<< getCodeActions docB (R 1 0 0 50)
+            =<< getCodeActions docB (R 1 8 1 14)
     executeCodeAction action
     contentAfterAction <- documentContents docB
     liftIO $ contentAfterAction @?= T.unlines expected
@@ -2449,7 +2449,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
     docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)
     _ <- waitForDiagnostics
     action <- pickActionWithTitle "Define select :: Int -> Bool"
-        =<< getCodeActions docB (R 1 0 0 50)
+        =<< getCodeActions docB (R 1 8 1 14)
     executeCodeAction action
     contentAfterAction <- documentContents docB
     liftIO $ contentAfterAction @?= T.unlines expected
@@ -2750,7 +2750,7 @@ fixConstructorImportTests = testGroup "fix import actions"
             [ "module ModuleB where"
             , "import ModuleA(Constructor)"
             ])
-      (Range (Position 1 10) (Position 1 11))
+      (Range (Position 1 15) (Position 1 26))
       "Fix import of A(Constructor)"
       (T.unlines
             [ "module ModuleB where"