diff --git a/flake.lock b/flake.lock index 6093aecea0..352483a773 100644 --- a/flake.lock +++ b/flake.lock @@ -36,17 +36,17 @@ }, "nixpkgs": { "locked": { - "lastModified": 1748792178, - "narHash": "sha256-BHmgfHlCJVNisJShVaEmfDIr/Ip58i/4oFGlD1iK6lk=", + "lastModified": 1748437873, + "narHash": "sha256-E2640ouB7VxooUQdCiDRo/rVXnr1ykgF9A7HrwWZVSo=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "5929de975bcf4c7c8d8b5ca65c8cd9ef9e44523e", + "rev": "c742ae7908a82c9bf23ce27bfca92a00e9bcd541", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixpkgs-unstable", "repo": "nixpkgs", + "rev": "c742ae7908a82c9bf23ce27bfca92a00e9bcd541", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 5ed4233fd1..1002eb87b5 100644 --- a/flake.nix +++ b/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 diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs index 06b6a9876b..0255886726 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Error.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 40ce1dda7b..c596d1fb82 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/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,7 +208,7 @@ 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) @@ -208,14 +216,19 @@ suggestSignature isQuickFix mGblSigs diag = -- 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. diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 53ee5200c0..a4132dd787 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/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 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 2057e76e57..da45083a08 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/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"