From 355e95c7ab58a097ca152be22245ca4e9180b3d6 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 27 Jun 2023 17:10:07 +0300 Subject: [PATCH 01/15] Generic support for resolve in hls packages --- hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Types.hs | 146 ++++++++++++++++++++++------ hls-test-utils/src/Test/Hls.hs | 22 +++++ 3 files changed, 139 insertions(+), 30 deletions(-) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 2762f335ff..64d1aa8263 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -62,6 +62,7 @@ library , opentelemetry >=0.4 , optparse-applicative , regex-tdfa >=1.3.1.0 + , row-types , text , transformers , unordered-containers diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c32b7173d0..f993544edc 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -12,6 +12,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -47,6 +48,8 @@ module Ide.Types , installSigUsr1Handler , responseError , lookupCommandProvider +, OwnedResolveData(..) +, mkCodeActionHandlerWithResolve ) where @@ -59,7 +62,9 @@ import System.Posix.Signals #endif import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens ((.~), (^.)) +import Control.Lens (_Just, (.~), (?~), (^.), (^?)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) @@ -74,6 +79,7 @@ import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe import Data.Ord +import Data.Row ((.!)) import Data.Semigroup import Data.String import qualified Data.Text as T @@ -85,7 +91,9 @@ import Ide.Plugin.Properties import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (LspM, getVirtualFile) +import Language.LSP.Server (LspM, LspT, + getClientCapabilities, + getVirtualFile) import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog @@ -403,32 +411,10 @@ instance PluginMethod Request Method_TextDocumentCodeAction where where uri = msgParams ^. L.textDocument . L.uri -instance PluginRequestMethod Method_TextDocumentCodeAction where - combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = - InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps - where - compat :: (Command |? CodeAction) -> (Command |? CodeAction) - compat x@(InL _) = x - compat x@(InR action) - | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport - = x - | otherwise = InL cmd - where - cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams) - cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))] - - wasRequested :: (Command |? CodeAction) -> Bool - wasRequested (InL _) = True - wasRequested (InR ca) - | Nothing <- _only context = True - | Just allowed <- _only context - -- See https://github.com/microsoft/language-server-protocol/issues/970 - -- This is somewhat vague, but due to the hierarchical nature of action kinds, we - -- should check whether the requested kind is a *prefix* of the action kind. - -- That means, for example, we will return actions with kinds `quickfix.import` and - -- `quickfix.somethingElse` if the requested kind is `quickfix`. - , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed - | otherwise = False +instance PluginMethod Request Method_CodeActionResolve where + pluginEnabled _ msgParams pluginDesc config = + pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) instance PluginMethod Request Method_TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = @@ -535,6 +521,38 @@ instance PluginMethod Request (Method_CustomMethod m) where pluginEnabled _ _ _ _ = True --- +instance PluginRequestMethod Method_TextDocumentCodeAction where + combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = + InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps + where + compat :: (Command |? CodeAction) -> (Command |? CodeAction) + compat x@(InL _) = x + compat x@(InR action) + | Just _ <- textDocCaps >>= _codeAction >>= _codeActionLiteralSupport + = x + | otherwise = InL cmd + where + cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams) + cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))] + + wasRequested :: (Command |? CodeAction) -> Bool + wasRequested (InL _) = True + wasRequested (InR ca) + | Nothing <- _only context = True + | Just allowed <- _only context + -- See https://github.com/microsoft/language-server-protocol/issues/970 + -- This is somewhat vague, but due to the hierarchical nature of action kinds, we + -- should check whether the requested kind is a *prefix* of the action kind. + -- That means, for example, we will return actions with kinds `quickfix.import` and + -- `quickfix.somethingElse` if the requested kind is `quickfix`. + , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed + | otherwise = False + +instance PluginRequestMethod Method_CodeActionResolve where + -- CodeAction resolve is currently only used to changed the edit field, thus + -- that's the only field we are combining. + combineResponses _ _ _ codeAction (toList -> codeActions) = codeAction & L.edit .~ mconcat ((^. L.edit) <$> codeActions) + instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x @@ -848,7 +866,7 @@ type CommandFunction ideState a newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) - deriving newtype (FromJSON, Hashable) + deriving newtype (ToJSON, FromJSON, Hashable) instance IsString PluginId where fromString = PluginId . T.pack @@ -949,7 +967,7 @@ instance HasTracing WorkspaceSymbolParams where instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams instance HasTracing CompletionItem - +instance HasTracing CodeAction -- --------------------------------------------------------------------- {-# NOINLINE pROCESS_ID #-} @@ -983,3 +1001,71 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif + +-- |When provided with both a codeAction provider and an affiliated codeAction +-- resolve provider, this function creates a handler that automatically uses +-- your resolve provider to fill out you original codeAction if the client doesn't +-- have codeAction resolve support. This means you don't have to check whether +-- the client supports resolve and act accordingly in your own providers. +mkCodeActionHandlerWithResolve + :: forall ideState. (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) + -> PluginHandlers ideState +mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = + let newCodeActionMethod ideState pid params = runExceptT $ + do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + caps <- lift getClientCapabilities + case codeActionReturn of + r@(InR _) -> pure r + (InL ls) | -- If the client supports resolve, we will wrap the resolve data in a owned + -- resolve data type to allow the server to know who to send the resolve request to + supportsResolve caps -> pure $ InL (wrapResolveData pid <$> ls) + --This is the actual part where we call resolveCodeAction which fills in the edit data for the client + | otherwise -> InL <$> traverse (resolveCodeAction ideState pid) ls + newCodeResolveMethod ideState pid params = + codeResolveMethod ideState pid (unwrapResolveData params) + in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod + where + supportsResolve :: ClientCapabilities -> Bool + supportsResolve caps = + caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True + && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of + Just row -> "edit" `elem` row .! #properties + _ -> False + dropData :: CodeAction -> CodeAction + dropData ca = ca & L.data_ .~ Nothing + resolveCodeAction :: ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) + resolveCodeAction _ideState _pid c@(InL _) = pure c + resolveCodeAction ideState pid (InR codeAction) = + fmap (InR . dropData) $ ExceptT $ codeResolveMethod ideState pid codeAction + -- We don't wrap commands + wrapResolveData _pid c@(InL _) = c + wrapResolveData pid (InR c@(CodeAction{_data_=Just x})) = + InR $ c & L.data_ ?~ toJSON (ORD pid x) + -- Neither do we wrap code actions's without data fields, + wrapResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c + unwrapResolveData c@CodeAction{_data_ = Just x} + | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v + -- If we can't successfully decode the value as a ORD type than + -- we just return the codeAction untouched. + unwrapResolveData c = c + +-- |Allow plugins to "own" resolve data, allowing only them to be queried for +-- the resolve action. This design has added flexibility at the cost of nested +-- Value types +data OwnedResolveData = ORD { + owner :: PluginId +, value :: Value +} deriving (Generic, Show) +instance ToJSON OwnedResolveData +instance FromJSON OwnedResolveData + +pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool +pluginResolverResponsible (Just val) pluginDesc = + case fromJSON val of + (Success (ORD o _)) -> pluginId pluginDesc == o + _ -> True -- We want to fail open in case our resolver is not using the ORD type +-- This is a wierd case, because anything that gets resolved should have a data +-- field, but in any case, failing open is safe enough. +pluginResolverResponsible Nothing _ = True diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 1864fdab49..97c0e03fe1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -20,6 +20,7 @@ module Test.Hls defaultTestRunner, goldenGitDiff, goldenWithHaskellDoc, + goldenWithHaskellAndCaps, goldenWithCabalDoc, goldenWithHaskellDocFormatter, goldenWithCabalDocFormatter, @@ -143,6 +144,27 @@ goldenWithHaskellDoc -> TestTree goldenWithHaskellDoc = goldenWithDoc "haskell" +goldenWithHaskellAndCaps + :: Pretty b + => ClientCapabilities + -> PluginTestDescriptor b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithHaskellAndCaps clientCaps plugin title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithServerAndCaps plugin clientCaps testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc + goldenWithCabalDoc :: Pretty b => PluginTestDescriptor b From fb49c3131cb98d16465b2aad6691453639fa3319 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 27 Jun 2023 17:18:28 +0300 Subject: [PATCH 02/15] Add a new code action resolve helper that falls backs to commands --- hls-plugin-api/src/Ide/Types.hs | 77 ++++++++++++++++++++++++--------- 1 file changed, 57 insertions(+), 20 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index f993544edc..04025b16ec 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -50,6 +50,7 @@ module Ide.Types , lookupCommandProvider , OwnedResolveData(..) , mkCodeActionHandlerWithResolve +, mkCodeActionWithResolveAndCommand ) where @@ -1016,40 +1017,76 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params caps <- lift getClientCapabilities case codeActionReturn of - r@(InR _) -> pure r + r@(InR Null) -> pure r (InL ls) | -- If the client supports resolve, we will wrap the resolve data in a owned -- resolve data type to allow the server to know who to send the resolve request to - supportsResolve caps -> pure $ InL (wrapResolveData pid <$> ls) + supportsCodeActionResolve caps -> pure $ InL (wrapCodeActionResolveData pid <$> ls) --This is the actual part where we call resolveCodeAction which fills in the edit data for the client | otherwise -> InL <$> traverse (resolveCodeAction ideState pid) ls newCodeResolveMethod ideState pid params = - codeResolveMethod ideState pid (unwrapResolveData params) + codeResolveMethod ideState pid (unwrapCodeActionResolveData params) in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod where - supportsResolve :: ClientCapabilities -> Bool - supportsResolve caps = - caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True - && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of - Just row -> "edit" `elem` row .! #properties - _ -> False dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing resolveCodeAction :: ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) resolveCodeAction _ideState _pid c@(InL _) = pure c resolveCodeAction ideState pid (InR codeAction) = fmap (InR . dropData) $ ExceptT $ codeResolveMethod ideState pid codeAction - -- We don't wrap commands - wrapResolveData _pid c@(InL _) = c - wrapResolveData pid (InR c@(CodeAction{_data_=Just x})) = - InR $ c & L.data_ ?~ toJSON (ORD pid x) - -- Neither do we wrap code actions's without data fields, - wrapResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c - unwrapResolveData c@CodeAction{_data_ = Just x} - | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v - -- If we can't successfully decode the value as a ORD type than - -- we just return the codeAction untouched. - unwrapResolveData c = c + +-- |When provided with both a codeAction provider that includes both a command +-- and a data field and a resolve provider, this function creates a handler that +-- defaults to using your command if the client doesn't have code action resolve +-- support. This means you don't have to check whether the client supports resolve +-- and act accordingly in your own providers. +mkCodeActionWithResolveAndCommand + :: forall ideState. (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) + -> PluginHandlers ideState +mkCodeActionWithResolveAndCommand codeActionMethod codeResolveMethod = + let newCodeActionMethod ideState pid params = runExceptT $ + do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + caps <- lift getClientCapabilities + case codeActionReturn of + r@(InR Null) -> pure r + (InL ls) | -- If the client supports resolve, we will wrap the resolve data in a owned + -- resolve data type to allow the server to know who to send the resolve request to + -- and dump the command fields. + supportsCodeActionResolve caps -> + pure $ InL (dropCommands . wrapCodeActionResolveData pid <$> ls) + -- If they do not we will drop the data field. + | otherwise -> pure $ InL $ dropData <$> ls + newCodeResolveMethod ideState pid params = + codeResolveMethod ideState pid (unwrapCodeActionResolveData params) + in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod + where dropData :: Command |? CodeAction -> Command |? CodeAction + dropData ca = ca & _R . L.data_ .~ Nothing + dropCommands :: Command |? CodeAction -> Command |? CodeAction + dropCommands ca = ca & _R . L.command .~ Nothing + +supportsCodeActionResolve :: ClientCapabilities -> Bool +supportsCodeActionResolve caps = + caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True + && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of + Just row -> "edit" `elem` row .! #properties + _ -> False + +-- We don't wrap commands +wrapCodeActionResolveData :: PluginId -> (a |? CodeAction) -> a |? CodeAction +wrapCodeActionResolveData _pid c@(InL _) = c +wrapCodeActionResolveData pid (InR c@(CodeAction{_data_=Just x})) = + InR $ c & L.data_ ?~ toJSON (ORD pid x) +-- Neither do we wrap code actions's without data fields, +wrapCodeActionResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c + +unwrapCodeActionResolveData :: CodeAction -> CodeAction +unwrapCodeActionResolveData c@CodeAction{_data_ = Just x} + | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v +-- If we can't successfully decode the value as a ORD type than +-- we just return the codeAction untouched. +unwrapCodeActionResolveData c = c -- |Allow plugins to "own" resolve data, allowing only them to be queried for -- the resolve action. This design has added flexibility at the cost of nested From d1d299b3a10805274f920a8ffa3410e5e109097d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 28 Jun 2023 17:17:37 +0300 Subject: [PATCH 03/15] add resolve capability set to hls-test-utils --- hls-test-utils/src/Test/Hls/Util.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index d361b0a8ec..a3e2146743 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -10,7 +10,9 @@ {-# LANGUAGE DataKinds #-} module Test.Hls.Util ( -- * Test Capabilities - codeActionSupportCaps + codeActionResolveCaps + , codeActionNoResolveCaps + , codeActionSupportCaps , expectCodeAction -- * Environment specifications -- for ignoring tests @@ -51,7 +53,7 @@ where import Control.Applicative.Combinators (skipManyTill, (<|>)) import Control.Exception (catch, throwIO) -import Control.Lens ((&), (?~), (^.)) +import Control.Lens ((&), (?~), (^.), _Just, (.~)) import Control.Monad import Control.Monad.IO.Class import qualified Data.Aeson as A @@ -92,6 +94,15 @@ codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing literalSupport = #codeActionKind .== (#valueSet .== []) +codeActionResolveCaps :: ClientCapabilities +codeActionResolveCaps = Test.fullCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (#properties .== ["edit"]) + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True + +codeActionNoResolveCaps :: ClientCapabilities +codeActionNoResolveCaps = Test.fullCaps + & (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport) .~ Nothing + & (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ False -- --------------------------------------------------------------------- -- Environment specification for ignoring tests -- --------------------------------------------------------------------- From 735feca0c5f7337237ea686ad5c376fbd9b2a755 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 29 Jun 2023 15:49:51 +0300 Subject: [PATCH 04/15] Add code lens resolve support --- hls-plugin-api/src/Ide/Types.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 04025b16ec..f752c17244 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -451,6 +451,11 @@ instance PluginMethod Request Method_TextDocumentCodeLens where where uri = msgParams ^. L.textDocument . L.uri +instance PluginMethod Request Method_CodeLensResolve where + pluginEnabled _ msgParams pluginDesc config = + pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) + instance PluginMethod Request Method_TextDocumentRename where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc) @@ -571,6 +576,10 @@ instance PluginRequestMethod Method_WorkspaceSymbol where instance PluginRequestMethod Method_TextDocumentCodeLens where +instance PluginRequestMethod Method_CodeLensResolve where + -- A resolve request should only ever get one response + combineResponses _ _ _ _ (x :| _) = x + instance PluginRequestMethod Method_TextDocumentRename where instance PluginRequestMethod Method_TextDocumentHover where @@ -969,6 +978,7 @@ instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams instance HasTracing CompletionItem instance HasTracing CodeAction +instance HasTracing CodeLens -- --------------------------------------------------------------------- {-# NOINLINE pROCESS_ID #-} From 251c91779f79229eeb3beff1e76d70d2bad08f33 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 1 Jul 2023 01:28:40 +0300 Subject: [PATCH 05/15] WIP --- .../hls-explicit-imports-plugin.cabal | 2 + .../src/Ide/Plugin/ExplicitImports.hs | 262 ++++++++++-------- 2 files changed, 145 insertions(+), 119 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 94e6e807e4..f6b1d20827 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -32,8 +32,10 @@ library , ghcide == 2.1.0.0 , hls-graph , hls-plugin-api == 2.1.0.0 + , lens , lsp , text + , transformers , unordered-containers default-language: Haskell2010 diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 741d3a87c3..09d665f913 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -19,17 +19,26 @@ module Ide.Plugin.ExplicitImports ) where import Control.DeepSeq +import Control.Lens ((&), (?~)) +import Control.Monad (replicateM) import Control.Monad.IO.Class -import Data.Aeson (ToJSON (toJSON), - Value (Null)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (throwE) +import Data.Aeson (Result (Success), + ToJSON (toJSON), + Value (Null), fromJSON) import Data.Aeson.Types (FromJSON) import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap as IM (IntMap, fromList, + (!?)) import Data.IORef (readIORef) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.String (fromString) import qualified Data.Text as T +import qualified Data.Unique as U (hashUnique, + newUnique) import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PositionMapping @@ -38,8 +47,16 @@ import Development.IDE.GHC.Compat import Development.IDE.Graph.Classes import Development.IDE.Types.Logger as Logger (Pretty (pretty)) import GHC.Generics (Generic) -import Ide.PluginUtils (mkLspCommand) +import Ide.Plugin.RangeMap (filterByRange) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybe, + handleMaybeM, + mkLspCommand, + pluginResponse) import Ide.Types +import Language.LSP.Protocol.Lens (HasDocumentChanges (documentChanges)) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server @@ -71,33 +88,36 @@ descriptorForModules recorder pred plId = (defaultPluginDescriptor plId) { -- This plugin provides a command handler - pluginCommands = [importLensCommand], + pluginCommands = [PluginCommand importCommandId "Explicit import command" runImportCommand], -- This plugin defines a new rule - pluginRules = minimalImportsRule recorder, - pluginHandlers = mconcat - [ -- This plugin provides code lenses - mkPluginHandler SMethod_TextDocumentCodeLens $ lensProvider pred + pluginRules = minimalImportsRule recorder pred, + pluginHandlers = + -- This plugin provides code lenses + mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider pred) + <> mkPluginHandler SMethod_CodeLensResolve lensResolveProvider -- This plugin provides code actions - , mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider pred - ] - } - --- | The command descriptor -importLensCommand :: PluginCommand IdeState -importLensCommand = - PluginCommand importCommandId "Explicit import command" runImportCommand + <> mkCodeActionHandlerWithResolve (codeActionProvider pred) codeActionResolveProvider --- | The type of the parameters accepted by our command -newtype ImportCommandParams = ImportCommandParams WorkspaceEdit - deriving (Generic) - deriving anyclass (FromJSON, ToJSON) + } -- | The actual command handler -runImportCommand :: CommandFunction IdeState ImportCommandParams -runImportCommand _state (ImportCommandParams edit) = do - -- This command simply triggers a workspace edit! - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right Null) +runImportCommand :: CommandFunction IdeState EIResolveData +runImportCommand ideState eird = pluginResponse $ do + case eird of + ResolveOne uri int -> do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + (range, text) <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? int + let edit = mkWorkspaceEdit uri range text + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + return Null + where mkWorkspaceEdit uri range text= + WorkspaceEdit {_changes = Just $ Map.fromList [(uri, [TextEdit range text])] + , _documentChanges = Nothing + , _changeAnnotations = Nothing} -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -117,65 +137,74 @@ lensProvider CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} -- VSCode uses URIs instead of file paths -- haskell-lsp provides conversion functions - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = do - mbMinImports <- runAction "MinimalImports" state $ useWithStale MinimalImports nfp + mbMinImports <- liftIO $ runAction "MinimalImports" state $ useWithStale MinimalImports nfp case mbMinImports of - -- Implement the provider logic: - -- for every import, if it's lacking a explicit list, generate a code lens - Just (MinimalImportsResult minImports, posMapping) -> do - commands <- - sequence - [ generateLens pId _uri edit - | (imp, Just minImport) <- minImports, - Just edit <- [mkExplicitEdit pred posMapping imp minImport] - ] - return $ Right $ InL $ catMaybes commands + Just (MinimalImportsResult minImports _ _, posMapping) -> do + let lens = [ generateLens _uri curRange int + | (range, int) <- minImports + , let Just curRange = toCurrentRange posMapping range] + return $ Right $ InL lens _ -> return $ Right $ InL [] | otherwise = return $ Right $ InL [] + where generateLens :: Uri -> Range -> Int -> CodeLens + generateLens uri range int = + CodeLens { _data_ = Just $ toJSON $ ResolveOne uri int + , _range = range + , _command = Nothing } + +lensResolveProvider :: PluginMethodHandler IdeState Method_CodeLensResolve +lensResolveProvider ideState plId cl@(CodeLens {_data_ = Just data_}) = pluginResponse $ do + case fromJSON data_ of + Success (ResolveOne uri int) -> do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + target <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? int + let updatedCodeLens = cl & L.command ?~ mkCommand plId uri target data_ + return updatedCodeLens + _ -> throwE "unable to parse data_ field of CodeLens" + where mkCommand :: PluginId -> Uri -> (Range, T.Text) -> Value -> Command + mkCommand pId uri (_, text) data_ = + let title = abbreviateImportTitle text + _arguments = Just [data_] + in mkLspCommand pId importCommandId title _arguments -- | If there are any implicit imports, provide one code action to turn them all -- into explicit imports. codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context) | TextDocumentIdentifier {_uri} <- docId, - Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ - do - pm <- runIde ideState $ use GetParsedModule nfp - let insideImport = case pm of - Just ParsedModule {pm_parsed_source} - | locImports <- hsmodImports (unLoc pm_parsed_source), - rangesImports <- map getLoc locImports -> - any (within range) rangesImports - _ -> False - if not insideImport - then return (Right (InL [])) - else do - minImports <- runAction "MinimalImports" ideState $ use MinimalImports nfp - let edits = - [ e - | (imp, Just explicit) <- - maybe [] getMinimalImportsResult minImports, - Just e <- [mkExplicitEdit pred zeroMapping imp explicit] - ] - caExplicitImports = InR CodeAction {..} - _title = "Make all imports explicit" - _kind = Just CodeActionKind_QuickFix - _command = Nothing - _edit = Just WorkspaceEdit {_changes, _documentChanges, _changeAnnotations} - _changes = Just $ Map.singleton _uri edits - _documentChanges = Nothing - _diagnostics = Nothing - _isPreferred = Nothing - _disabled = Nothing - _data_ = Nothing - _changeAnnotations = Nothing - return $ Right $ InL [caExplicitImports | not (null edits)] - | otherwise = - return $ Right $ InL [] - + Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = do + minImports <- liftIO $ runAction "MinimalImports" ideState $ use MinimalImports nfp + case minImports of + Just (MinimalImportsResult _ minImports _) -> do + let relevantCodeActions = filterByRange range minImports + allExplicit = + [InR $ mkCodeAction "Make all imports explicit" (Just $ toJSON $ ResolveAll _uri) + | not $ null relevantCodeActions ] + toCodeAction uri (range, int) = + mkCodeAction "Make this import explicit" (Just $ toJSON $ ResolveOne uri int) + return $ Right $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit) + | otherwise = return $ Right $ InL [] + where mkCodeAction title data_ = + CodeAction + { _title = title + , _kind = Just CodeActionKind_QuickFix + , _command = Nothing + , _edit = Nothing + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _data_ = data_} + +codeActionResolveProvider :: PluginMethodHandler IdeState Method_CodeActionResolve +codeActionResolveProvider = undefined -------------------------------------------------------------------------------- data MinimalImports = MinimalImports @@ -187,13 +216,22 @@ instance NFData MinimalImports type instance RuleResult MinimalImports = MinimalImportsResult -newtype MinimalImportsResult = MinimalImportsResult - {getMinimalImportsResult :: [(LImportDecl GhcRn, Maybe T.Text)]} +data MinimalImportsResult = MinimalImportsResult + { forLens :: [(Range, Int)] + , forCodeActions :: RM.RangeMap (Range, Int) + , forResolve :: IM.IntMap (Range, T.Text) } instance Show MinimalImportsResult where show _ = "" instance NFData MinimalImportsResult where rnf = rwhnf +data EIResolveData = ResolveOne + { uri :: Uri + , int :: Int } + | ResolveAll + { uri :: Uri } + deriving (Generic, ToJSON, FromJSON) + exportedModuleStrings :: ParsedModule -> [String] exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} | Just export <- hsmodExports, @@ -201,35 +239,47 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} = map (T.unpack . printOutputable) exports exportedModuleStrings _ = [] -minimalImportsRule :: Recorder (WithPriority Log) -> Rules () -minimalImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do +minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () +minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do -- Get the typechecking artifacts from the module - tmr <- use TypeCheck nfp + Just tmr <- use TypeCheck nfp -- We also need a GHC session with all the dependencies - hsc <- use GhcSessionDeps nfp + Just hsc <- use GhcSessionDeps nfp -- Use the GHC api to extract the "minimal" imports - (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, Just mbMinImports) <- liftIO $ extractMinimalImports (Just hsc) (Just tmr) let importsMap = Map.fromList [ (realSrcSpanStart l, printOutputable i) - | L (locA -> RealSrcSpan l _) i <- fromMaybe [] mbMinImports - , not (isImplicitPrelude i) + | L (locA -> RealSrcSpan l _) i <- mbMinImports + -- Don't we already take care of this with the predicate? + --, not (isImplicitPrelude i) ] res = - [ (i, Map.lookup (realSrcSpanStart l) importsMap) - | i <- imports - , RealSrcSpan l _ <- [getLoc i] + [ (realSrcSpanToRange l, minImport) + | i@(L (locA -> src) imp) <- imports + , not (isQualifiedImport imp) + , not (isExplicitImport imp) + , let L _ mn = ideclName imp + , pred mn + , let RealSrcSpan l _ = getLoc i + , let Just minImport = Map.lookup (realSrcSpanStart l) importsMap ] - return ([], MinimalImportsResult res <$ mbMinImports) - where - isImplicitPrelude :: (Outputable a) => a -> Bool + uniques <- liftIO $ replicateM (length res) (U.hashUnique <$> U.newUnique) + let uniqueAndRangeAndText = zip uniques res + rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] + return ([], Just $ MinimalImportsResult + rangeAndUnique + (RM.fromList fst rangeAndUnique) + (IM.fromList uniqueAndRangeAndText)) +{- where + isImplicitPrelude :: (Outputable a) => a -> Bool isImplicitPrelude importDecl = T.isPrefixOf implicitPreludeImportPrefix (printOutputable importDecl) -- | This is the prefix of an implicit prelude import which should be ignored, -- when considering the minimal imports rule implicitPreludeImportPrefix :: T.Text -implicitPreludeImportPrefix = "import (implicit) Prelude" +implicitPreludeImportPrefix = "import (implicit) Prelude" -} -------------------------------------------------------------------------------- @@ -265,26 +315,14 @@ extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do notExported [] _ = True notExported exports (L _ ImportDecl{ideclName = L _ name}) = not $ any (\e -> ("module " ++ moduleNameString name) == e) exports -extractMinimalImports _ _ = return ([], Nothing) -mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit -mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit - -- Explicit import list case +isExplicitImport :: ImportDecl GhcRn -> Bool #if MIN_VERSION_ghc (9,5,0) - | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = +isExplicitImport ImportDecl {ideclImportList = Just (Exactly, _)} = True #else - | ImportDecl {ideclHiding = Just (False, _)} <- imp = +isExplicitImport ImportDecl {ideclHiding = Just (False, _)} = True #endif - Nothing - | not (isQualifiedImport imp), - RealSrcSpan l _ <- src, - L _ mn <- ideclName imp, - pred mn, - Just rng <- toCurrentRange posMapping $ realSrcSpanToRange l = - Just $ TextEdit rng explicit - | otherwise = - Nothing - +isExplicitImport _ = False -- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things, -- but at the moment I don't believe we know it. -- 80 columns is traditional, but Haskellers tend to use longer lines (citation needed) and it's @@ -294,21 +332,7 @@ maxColumns = 120 -- | Given an import declaration, generate a code lens unless it has an -- explicit import list or it's qualified -generateLens :: PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens) -generateLens pId uri importEdit@TextEdit {_range, _newText} = do - let - title = abbreviateImportTitle _newText - -- the code lens has no extra data - _data_ = Nothing - -- an edit that replaces the whole declaration with the explicit one - edit = WorkspaceEdit (Just editsMap) Nothing Nothing - editsMap = Map.fromList [(uri, [importEdit])] - -- the command argument is simply the edit - _arguments = Just [toJSON $ ImportCommandParams edit] - -- create the command - _command = Just $ mkLspCommand pId importCommandId title _arguments - -- create and return the code lens - return $ Just CodeLens {..} + -- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). From ace6dcf99cc3968e09783639b398bac77d4ce4f6 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sun, 2 Jul 2023 21:57:32 +0300 Subject: [PATCH 06/15] Finish up explicit imports and add tests Probably still needs some clean up and general refactoring --- .../hls-explicit-imports-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitImports.hs | 57 +++++++++++++------ .../hls-explicit-imports-plugin/test/Main.hs | 56 +++++++++++++++--- .../test/testdata/B.hs | 7 +++ .../test/testdata/OnlyThis.expected.hs | 7 +++ .../test/testdata/OnlyThis.hs | 7 +++ .../test/testdata/UsualCase.expected.hs | 2 +- .../test/testdata/UsualCase.hs | 2 +- .../test/testdata/hie.yaml | 3 + 9 files changed, 115 insertions(+), 27 deletions(-) create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/B.hs create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index f6b1d20827..c2b71cee6f 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -55,5 +55,6 @@ test-suite tests , filepath , hls-explicit-imports-plugin , hls-test-utils + , lens , lsp-types , text diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 09d665f913..5dc672f010 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -17,7 +17,6 @@ module Ide.Plugin.ExplicitImports , abbreviateImportTitle , Log(..) ) where - import Control.DeepSeq import Control.Lens ((&), (?~)) import Control.Monad (replicateM) @@ -29,8 +28,8 @@ import Data.Aeson (Result (Success), Value (Null), fromJSON) import Data.Aeson.Types (FromJSON) import qualified Data.HashMap.Strict as HashMap -import qualified Data.IntMap as IM (IntMap, fromList, - (!?)) +import qualified Data.IntMap as IM (IntMap, elems, + fromList, (!?)) import Data.IORef (readIORef) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, @@ -180,17 +179,18 @@ lensResolveProvider ideState plId cl@(CodeLens {_data_ = Just data_}) = pluginRe codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context) | TextDocumentIdentifier {_uri} <- docId, - Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = do - minImports <- liftIO $ runAction "MinimalImports" ideState $ use MinimalImports nfp - case minImports of - Just (MinimalImportsResult _ minImports _) -> do - let relevantCodeActions = filterByRange range minImports - allExplicit = - [InR $ mkCodeAction "Make all imports explicit" (Just $ toJSON $ ResolveAll _uri) - | not $ null relevantCodeActions ] - toCodeAction uri (range, int) = - mkCodeAction "Make this import explicit" (Just $ toJSON $ ResolveOne uri int) - return $ Right $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit) + Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = pluginResponse $ do + (MinimalImportsResult _ minImports _) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let relevantCodeActions = filterByRange range minImports + allExplicit = + [InR $ mkCodeAction "Make all imports explicit" (Just $ toJSON $ ResolveAll _uri) + | not $ null relevantCodeActions ] + toCodeAction uri (range, int) = + mkCodeAction "Make this import explicit" (Just $ toJSON $ ResolveOne uri int) + pure $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit) | otherwise = return $ Right $ InL [] where mkCodeAction title data_ = CodeAction @@ -204,7 +204,31 @@ codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context , _data_ = data_} codeActionResolveProvider :: PluginMethodHandler IdeState Method_CodeActionResolve -codeActionResolveProvider = undefined +codeActionResolveProvider ideState plId ca@(CodeAction{_data_= Just value}) = + pluginResponse $ do + case fromJSON value of + Success (ResolveOne uri int) -> do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + (range, text) <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? int + let wedit = mkWorkspaceEdit uri [TextEdit range text] + pure $ ca & L.edit ?~ wedit + Success (ResolveAll uri) -> do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let edits = uncurry TextEdit <$> IM.elems resolveMinImp + wedit = mkWorkspaceEdit uri edits + pure $ ca & L.edit ?~ wedit + where mkWorkspaceEdit uri edits= + WorkspaceEdit {_changes = Just $ Map.fromList [(uri, edits)] + , _documentChanges = Nothing + , _changeAnnotations = Nothing} -------------------------------------------------------------------------------- data MinimalImports = MinimalImports @@ -262,7 +286,7 @@ minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \Mi , let L _ mn = ideclName imp , pred mn , let RealSrcSpan l _ = getLoc i - , let Just minImport = Map.lookup (realSrcSpanStart l) importsMap + , Just minImport <- [Map.lookup (realSrcSpanStart l) importsMap] ] uniques <- liftIO $ replicateM (length res) (U.hashUnique <$> U.newUnique) let uniqueAndRangeAndText = zip uniques res @@ -323,6 +347,7 @@ isExplicitImport ImportDecl {ideclImportList = Just (Exactly, _)} = True isExplicitImport ImportDecl {ideclHiding = Just (False, _)} = True #endif isExplicitImport _ = False + -- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things, -- but at the moment I don't believe we know it. -- 80 columns is traditional, but Haskellers tend to use longer lines (citation needed) and it's diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 6a5303ecba..a16b203eac 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -8,10 +8,12 @@ module Main ( main ) where +import Control.Lens ((^.)) import Data.Foldable (find, forM_) import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.ExplicitImports as ExplicitImports +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import System.FilePath ((<.>), ()) import Test.Hls @@ -26,7 +28,10 @@ main :: IO () main = defaultTestRunner $ testGroup "Make imports explicit" - [ codeActionGoldenTest "UsualCase" 3 0 + [ codeActionAllGoldenTest "UsualCase" 3 0 + , codeActionAllResolveGoldenTest "UsualCase" 3 0 + , codeActionOnlyGoldenTest "OnlyThis" 3 0 + , codeActionOnlyResolveGoldenTest "OnlyThis" 3 0 , codeLensGoldenTest "UsualCase" 0 , testCase "No CodeAction when exported" $ runSessionWithServer explicitImportsPlugin testDataDir $ do @@ -65,13 +70,40 @@ main = defaultTestRunner $ -- code action tests -codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree -codeActionGoldenTest fp l c = goldenWithExplicitImports fp $ \doc -> do +codeActionAllGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllGoldenTest fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do actions <- getCodeActions doc (pointRange l c) case find ((== Just "Make all imports explicit") . caTitle) actions of Just (InR x) -> executeCodeAction x _ -> liftIO $ assertFailure "Unable to find CodeAction" +codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + let Just (InR x) = find ((== Just "Make all imports explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +codeActionOnlyGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyGoldenTest fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + let Just (InR x) = find ((== Just "Make this import explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +resolveCodeAction :: CodeAction -> Session CodeAction +resolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + let Right resolved = resolveResponse ^. L.result + pure resolved + caTitle :: (Command |? CodeAction) -> Maybe Text caTitle (InR CodeAction {_title}) = Just _title caTitle _ = Nothing @@ -79,10 +111,16 @@ caTitle _ = Nothing -- code lens tests codeLensGoldenTest :: FilePath -> Int -> TestTree -codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports fp $ \doc -> do - codeLens <- (!! codeLensIdx) <$> getCodeLensesBy isExplicitImports doc - mapM_ executeCmd - [c | CodeLens{_command = Just c} <- [codeLens]] +codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports " code lens" fp codeActionNoResolveCaps $ \doc -> do + (codeLens: _) <- getCodeLenses doc + CodeLens {_command = Just c} <- resolveCodeLens codeLens + executeCmd c + +resolveCodeLens :: CodeLens -> Session CodeLens +resolveCodeLens cl = do + resolveResponse <- request SMethod_CodeLensResolve cl + let Right resolved = resolveResponse ^. L.result + pure resolved getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] getCodeLensesBy f doc = filter f <$> getCodeLenses doc @@ -102,8 +140,8 @@ executeCmd cmd = do -- helpers -goldenWithExplicitImports :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithExplicitImports fp = goldenWithHaskellDoc explicitImportsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenWithExplicitImports :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithExplicitImports title fp caps = goldenWithHaskellAndCaps caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs" testDataDir :: String testDataDir = "test" "testdata" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/B.hs b/plugins/hls-explicit-imports-plugin/test/testdata/B.hs new file mode 100644 index 0000000000..80159dc10b --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/B.hs @@ -0,0 +1,7 @@ +module B where + +b1 :: String +b1 = "b1" + +b2 :: String +b2 = "b2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs new file mode 100644 index 0000000000..5911ee5562 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs @@ -0,0 +1,7 @@ +module OnlyThis where + +import A ( a1 ) +import B + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs new file mode 100644 index 0000000000..9663d1b174 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs @@ -0,0 +1,7 @@ +module OnlyThis where + +import A +import B + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs index 8355eafde2..ec0b512b3b 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs @@ -1,4 +1,4 @@ -module Main where +module UsualCase where import A ( a1 ) diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs index b5c65ba8ea..4bf33dc094 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs @@ -1,4 +1,4 @@ -module Main where +module UsualCase where import A diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml index c1a3993dc4..fe43a0712d 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml +++ b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml @@ -1,6 +1,9 @@ + cradle: direct: arguments: + - OnlyThis.hs - UsualCase.hs - Exported.hs - A.hs + - B.hs From af4c70f1a3df3f806d6179865cb570375469d5f5 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 3 Jul 2023 23:33:34 +0300 Subject: [PATCH 07/15] michaelpj's suggestions --- .../src/Ide/Plugin/ExplicitImports.hs | 277 +++++++++--------- 1 file changed, 135 insertions(+), 142 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 5dc672f010..0a16e6c8f7 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -17,25 +18,25 @@ module Ide.Plugin.ExplicitImports , abbreviateImportTitle , Log(..) ) where + import Control.DeepSeq import Control.Lens ((&), (?~)) -import Control.Monad (replicateM) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (throwE) -import Data.Aeson (Result (Success), - ToJSON (toJSON), - Value (Null), fromJSON) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as A (Result (..), + ToJSON (toJSON), + Value (Null), + fromJSON) import Data.Aeson.Types (FromJSON) -import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap as IM (IntMap, elems, fromList, (!?)) import Data.IORef (readIORef) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, - isJust) import Data.String (fromString) import qualified Data.Text as T +import Data.Traversable (for) import qualified Data.Unique as U (hashUnique, newUnique) import Development.IDE hiding (pluginHandlers, @@ -44,17 +45,14 @@ import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.Graph.Classes -import Development.IDE.Types.Logger as Logger (Pretty (pretty)) import GHC.Generics (Generic) import Ide.Plugin.RangeMap (filterByRange) import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) import Ide.PluginUtils (getNormalizedFilePath, handleMaybe, handleMaybeM, - mkLspCommand, pluginResponse) import Ide.Types -import Language.LSP.Protocol.Lens (HasDocumentChanges (documentChanges)) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null) @@ -63,13 +61,15 @@ import Language.LSP.Server importCommandId :: CommandId importCommandId = "ImportLensCommand" -newtype Log +data Log = LogShake Shake.Log + | LogResponseError ResponseError deriving Show instance Pretty Log where pretty = \case LogShake log -> pretty log + LogResponseError msg -> pretty (show msg) -- | The "main" function of a plugin descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -87,36 +87,30 @@ descriptorForModules recorder pred plId = (defaultPluginDescriptor plId) { -- This plugin provides a command handler - pluginCommands = [PluginCommand importCommandId "Explicit import command" runImportCommand], + pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)], -- This plugin defines a new rule pluginRules = minimalImportsRule recorder pred, pluginHandlers = -- This plugin provides code lenses - mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider pred) - <> mkPluginHandler SMethod_CodeLensResolve lensResolveProvider + mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) + <> mkPluginHandler SMethod_CodeLensResolve (lensResolveProvider recorder) -- This plugin provides code actions - <> mkCodeActionHandlerWithResolve (codeActionProvider pred) codeActionResolveProvider + <> mkCodeActionHandlerWithResolve (codeActionProvider recorder) (codeActionResolveProvider recorder) } -- | The actual command handler -runImportCommand :: CommandFunction IdeState EIResolveData -runImportCommand ideState eird = pluginResponse $ do - case eird of - ResolveOne uri int -> do - nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp - (range, text) <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? int - let edit = mkWorkspaceEdit uri range text - _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return Null - where mkWorkspaceEdit uri range text= - WorkspaceEdit {_changes = Just $ Map.fromList [(uri, [TextEdit range text])] - , _documentChanges = Nothing - , _changeAnnotations = Nothing} +runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIResolveData +runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do + wedit <- resolveWTextEdit ideState eird + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors + return A.Null + where logErrors (Left re@(ResponseError{})) = do + logWith recorder Error (LogResponseError re) + pure () + logErrors (Right _) = pure () +runImportCommand _ _ (ResolveAll _) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for command handler: ResolveAll" Nothing -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -128,70 +122,66 @@ runImportCommand ideState eird = pluginResponse $ do -- the provider should produce one code lens associated to the import statement: -- -- > import Data.List (intercalate, sortBy) -lensProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens -lensProvider - pred - state -- ghcide state, used to retrieve typechecking artifacts - pId -- plugin Id - CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} - -- VSCode uses URIs instead of file paths - -- haskell-lsp provides conversion functions - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = - do - mbMinImports <- liftIO $ runAction "MinimalImports" state $ useWithStale MinimalImports nfp - case mbMinImports of - Just (MinimalImportsResult minImports _ _, posMapping) -> do - let lens = [ generateLens _uri curRange int - | (range, int) <- minImports - , let Just curRange = toCurrentRange posMapping range] - return $ Right $ InL lens - _ -> - return $ Right $ InL [] - | otherwise = - return $ Right $ InL [] +lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} + = pluginResponse $ do + nfp <- getNormalizedFilePath _uri + mbMinImports <- liftIO $ runAction "MinimalImports" state $ useWithStale MinimalImports nfp + case mbMinImports of + Just (MinimalImportsResult minImports _ _, posMapping) -> do + let lens = [ generateLens _uri curRange int + | (range, int) <- minImports + , Just curRange <- [toCurrentRange posMapping range]] + pure $ InL lens + _ -> + pure $ InL [] where generateLens :: Uri -> Range -> Int -> CodeLens generateLens uri range int = - CodeLens { _data_ = Just $ toJSON $ ResolveOne uri int + CodeLens { _data_ = Just $ A.toJSON $ ResolveOne uri int , _range = range , _command = Nothing } -lensResolveProvider :: PluginMethodHandler IdeState Method_CodeLensResolve -lensResolveProvider ideState plId cl@(CodeLens {_data_ = Just data_}) = pluginResponse $ do - case fromJSON data_ of - Success (ResolveOne uri int) -> do - nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp - target <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? int - let updatedCodeLens = cl & L.command ?~ mkCommand plId uri target data_ - return updatedCodeLens - _ -> throwE "unable to parse data_ field of CodeLens" - where mkCommand :: PluginId -> Uri -> (Range, T.Text) -> Value -> Command - mkCommand pId uri (_, text) data_ = - let title = abbreviateImportTitle text +lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeLensResolve +lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSON -> A.Success (ResolveOne uri uid))}) + = pluginResponse $ do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + target <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? uid + let updatedCodeLens = cl & L.command ?~ mkCommand plId target data_ + pure updatedCodeLens + where mkCommand :: PluginId -> TextEdit -> A.Value -> Command + mkCommand pId TextEdit{_newText} data_ = + let title = abbreviateImportTitle _newText _arguments = Just [data_] in mkLspCommand pId importCommandId title _arguments - --- | If there are any implicit imports, provide one code action to turn them all +lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON -> A.Success (ResolveAll _))}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for lens resolve handler: ResolveAll" Nothing +lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON @EIResolveData -> (A.Error (T.pack -> str)))}) = + pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing +lensResolveProvider _ _ _ (CodeLens {_data_ = _}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for lens resolve handler: (Probably Nothing)" Nothing + +-- | If there are any implicit imports, provide both one code action per import +-- to make that specific import explicit, and one code action to turn them all -- into explicit imports. -codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context) - | TextDocumentIdentifier {_uri} <- docId, - Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = pluginResponse $ do +codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) + = pluginResponse $ do + nfp <- getNormalizedFilePath _uri (MinimalImportsResult _ minImports _) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp let relevantCodeActions = filterByRange range minImports allExplicit = - [InR $ mkCodeAction "Make all imports explicit" (Just $ toJSON $ ResolveAll _uri) + [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ResolveAll _uri) | not $ null relevantCodeActions ] - toCodeAction uri (range, int) = - mkCodeAction "Make this import explicit" (Just $ toJSON $ ResolveOne uri int) + toCodeAction uri (_, int) = + mkCodeAction "Make this import explicit" (Just $ A.toJSON $ ResolveOne uri int) pure $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit) - | otherwise = return $ Right $ InL [] where mkCodeAction title data_ = CodeAction { _title = title @@ -203,34 +193,41 @@ codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context , _disabled = Nothing , _data_ = data_} -codeActionResolveProvider :: PluginMethodHandler IdeState Method_CodeActionResolve -codeActionResolveProvider ideState plId ca@(CodeAction{_data_= Just value}) = +codeActionResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeActionResolve +codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON -> A.Success rd)}) = pluginResponse $ do - case fromJSON value of - Success (ResolveOne uri int) -> do - nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp - (range, text) <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? int - let wedit = mkWorkspaceEdit uri [TextEdit range text] - pure $ ca & L.edit ?~ wedit - Success (ResolveAll uri) -> do - nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- - handleMaybeM "Unable to run Minimal Imports" - $ liftIO - $ runAction "MinimalImports" ideState $ use MinimalImports nfp - let edits = uncurry TextEdit <$> IM.elems resolveMinImp - wedit = mkWorkspaceEdit uri edits - pure $ ca & L.edit ?~ wedit - where mkWorkspaceEdit uri edits= - WorkspaceEdit {_changes = Just $ Map.fromList [(uri, edits)] - , _documentChanges = Nothing - , _changeAnnotations = Nothing} + wedit <- resolveWTextEdit ideState rd + pure $ ca & L.edit ?~ wedit +codeActionResolveProvider _ _ _ (CodeAction{_data_= Just (A.fromJSON @EIResolveData -> A.Error (T.pack -> str))}) = + pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing +codeActionResolveProvider _ _ _ (CodeAction {_data_ = _}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for code action resolve handler: (Probably Nothing)" Nothing -------------------------------------------------------------------------------- +resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit +resolveWTextEdit ideState (ResolveOne uri int) = do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + tedit <- handleMaybe "Unable to resolve text edit" $ resolveMinImp IM.!? int + pure $ mkWorkspaceEdit uri [tedit] +resolveWTextEdit ideState (ResolveAll uri) = do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult _ _ resolveMinImp) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let edits = IM.elems resolveMinImp + pure $ mkWorkspaceEdit uri edits + +mkWorkspaceEdit :: Uri -> [TextEdit] -> WorkspaceEdit +mkWorkspaceEdit uri edits = + WorkspaceEdit {_changes = Just $ Map.fromList [(uri, edits)] + , _documentChanges = Nothing + , _changeAnnotations = Nothing} + data MinimalImports = MinimalImports deriving (Show, Generic, Eq, Ord) @@ -241,20 +238,29 @@ instance NFData MinimalImports type instance RuleResult MinimalImports = MinimalImportsResult data MinimalImportsResult = MinimalImportsResult - { forLens :: [(Range, Int)] + { -- |For providing the code lenses we need to have a range, and a unique id + -- that is later resolved to the new text for each import. It is stored in + -- a list, because we always need to provide all the code lens in a file. + forLens :: [(Range, Int)] + -- |For the code actions we have the same data as for the code lenses, but + -- we store it in a RangeMap, because that allows us to filter on a specific + -- range with better performance, and code actions are almost allways only + -- requested for a specific range , forCodeActions :: RM.RangeMap (Range, Int) - , forResolve :: IM.IntMap (Range, T.Text) } + -- |For resolve we have an intMap where for every previously provied unique id + -- we provide a textEdit to allow our code actions or code lens to be resolved + , forResolve :: IM.IntMap TextEdit } instance Show MinimalImportsResult where show _ = "" instance NFData MinimalImportsResult where rnf = rwhnf data EIResolveData = ResolveOne - { uri :: Uri - , int :: Int } + { uri :: Uri + , importId :: Int } | ResolveAll { uri :: Uri } - deriving (Generic, ToJSON, FromJSON) + deriving (Generic, A.ToJSON, FromJSON) exportedModuleStrings :: ParsedModule -> [String] exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} @@ -270,66 +276,56 @@ minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \Mi -- We also need a GHC session with all the dependencies Just hsc <- use GhcSessionDeps nfp -- Use the GHC api to extract the "minimal" imports - (imports, Just mbMinImports) <- liftIO $ extractMinimalImports (Just hsc) (Just tmr) + Just (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList [ (realSrcSpanStart l, printOutputable i) | L (locA -> RealSrcSpan l _) i <- mbMinImports - -- Don't we already take care of this with the predicate? - --, not (isImplicitPrelude i) ] res = [ (realSrcSpanToRange l, minImport) - | i@(L (locA -> src) imp) <- imports + | i@(L _ imp) <- imports , not (isQualifiedImport imp) , not (isExplicitImport imp) , let L _ mn = ideclName imp , pred mn - , let RealSrcSpan l _ = getLoc i + , RealSrcSpan l _ <- [getLoc i] , Just minImport <- [Map.lookup (realSrcSpanStart l) importsMap] ] - uniques <- liftIO $ replicateM (length res) (U.hashUnique <$> U.newUnique) - let uniqueAndRangeAndText = zip uniques res - rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] + uniqueAndRangeAndText <- liftIO $ for res $ \rt -> do + u <- U.hashUnique <$> U.newUnique + pure (u, rt) + let rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] return ([], Just $ MinimalImportsResult rangeAndUnique (RM.fromList fst rangeAndUnique) - (IM.fromList uniqueAndRangeAndText)) -{- where - isImplicitPrelude :: (Outputable a) => a -> Bool - isImplicitPrelude importDecl = - T.isPrefixOf implicitPreludeImportPrefix (printOutputable importDecl) - --- | This is the prefix of an implicit prelude import which should be ignored, --- when considering the minimal imports rule -implicitPreludeImportPrefix :: T.Text -implicitPreludeImportPrefix = "import (implicit) Prelude" -} + (IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText))) -------------------------------------------------------------------------------- -- | Use the ghc api to extract a minimal, explicit set of imports for this module extractMinimalImports :: - Maybe HscEnvEq -> - Maybe TcModuleResult -> - IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn]) -extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do + HscEnvEq -> + TcModuleResult -> + IO (Maybe ([LImportDecl GhcRn], [LImportDecl GhcRn])) +extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do -- extract the original imports and the typechecking environment let tcEnv = tmrTypechecked (_, imports, _, _) = tmrRenamed ParsedModule {pm_parsed_source = L loc _} = tmrParsed emss = exportedModuleStrings tmrParsed - span = fromMaybe (error "expected real") $ realSpan loc + Just span <- pure $ realSpan loc -- Don't make suggestions for modules which are also exported, the user probably doesn't want this! -- See https://github.com/haskell/haskell-language-server/issues/2079 let notExportedImports = filter (notExported emss) imports -- GHC is secretly full of mutable state - gblElts <- readIORef (tcg_used_gres tcEnv) + gblElts <- liftIO $ readIORef (tcg_used_gres tcEnv) -- call findImportUsage does exactly what we need -- GHC is full of treats like this let usage = findImportUsage notExportedImports gblElts - (_, minimalImports) <- + (_, Just minimalImports) <- liftIO $ initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage -- return both the original imports and the computed minimal ones @@ -355,9 +351,6 @@ isExplicitImport _ = False maxColumns :: Int maxColumns = 120 --- | Given an import declaration, generate a code lens unless it has an --- explicit import list or it's qualified - -- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). From 9fb0512c0b521ebb59421016e2ff3cfcf9eb82c0 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 3 Jul 2023 20:34:11 +0000 Subject: [PATCH 08/15] refine-imports --no-verify commit --- .../src/Ide/Plugin/RefineImports.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 42a401e2ad..b8620ea6ce 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -186,9 +186,9 @@ instance NFData RefineImportsResult where rnf = rwhnf refineImportsRule :: Recorder (WithPriority Log) -> Rules () refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> do -- Get the typechecking artifacts from the module - tmr <- use TypeCheck nfp + Just tmr <- use TypeCheck nfp -- We also need a GHC session with all the dependencies - hsc <- use GhcSessionDeps nfp + Just hsc <- use GhcSessionDeps nfp -- 2 layer map ModuleName -> ModuleName -> [Avails] (exports) import2Map <- do @@ -205,7 +205,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -- We shouldn't blindly refine imports -- instead we should generate imports statements -- for modules/symbols actually got used - (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + Just (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let filterByImport :: LImportDecl GhcRn @@ -259,7 +259,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm . Map.toList $ filteredInnerImports) -- for every minimal imports - | Just minImports <- [mbMinImports] + | minImports <- [mbMinImports] , i@(L _ ImportDecl{ideclName = L _ mn}) <- minImports -- we check for the inner imports , Just innerImports <- [Map.lookup mn import2Map] @@ -268,7 +268,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -- if no symbols from this modules then don't need to generate new import , not $ null filteredInnerImports ] - return ([], RefineImportsResult res <$ mbMinImports) + return ([], Just $ RefineImportsResult res) where -- Check if a name is exposed by AvailInfo (the available information of a module) From 20874be0a15344063103c630a3ac48056b858461 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 4 Jul 2023 15:10:36 +0300 Subject: [PATCH 09/15] Spelling mistakes and useWithStale for rule --- .../hls-explicit-imports-plugin.cabal | 5 ++ .../src/Ide/Plugin/ExplicitImports.hs | 47 +++++++++---------- 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index c2b71cee6f..4a72090807 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -19,7 +19,11 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git +common warnings + ghc-options: -Wall + library + import: warnings buildable: True exposed-modules: Ide.Plugin.ExplicitImports hs-source-dirs: src @@ -44,6 +48,7 @@ library TypeOperators test-suite tests + import: warnings buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 0a16e6c8f7..a5625db21f 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -110,7 +110,7 @@ runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do pure () logErrors (Right _) = pure () runImportCommand _ _ (ResolveAll _) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for command handler: ResolveAll" Nothing + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for command handler: ResolveAll" Nothing -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -126,12 +126,11 @@ lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Meth lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = pluginResponse $ do nfp <- getNormalizedFilePath _uri - mbMinImports <- liftIO $ runAction "MinimalImports" state $ useWithStale MinimalImports nfp + mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp case mbMinImports of - Just (MinimalImportsResult minImports _ _, posMapping) -> do - let lens = [ generateLens _uri curRange int - | (range, int) <- minImports - , Just curRange <- [toCurrentRange posMapping range]] + Just (MinimalImportsResult minImports _ _) -> do + let lens = [ generateLens _uri range int + | (range, int) <- minImports] pure $ InL lens _ -> pure $ InL [] @@ -158,11 +157,11 @@ lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSO _arguments = Just [data_] in mkLspCommand pId importCommandId title _arguments lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON -> A.Success (ResolveAll _))}) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for lens resolve handler: ResolveAll" Nothing + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: ResolveAll" Nothing lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON @EIResolveData -> (A.Error (T.pack -> str)))}) = pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing lensResolveProvider _ _ _ (CodeLens {_data_ = _}) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for lens resolve handler: (Probably Nothing)" Nothing + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: (Probably Nothing)" Nothing -- | If there are any implicit imports, provide both one code action per import -- to make that specific import explicit, and one code action to turn them all @@ -201,7 +200,7 @@ codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON - codeActionResolveProvider _ _ _ (CodeAction{_data_= Just (A.fromJSON @EIResolveData -> A.Error (T.pack -> str))}) = pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing codeActionResolveProvider _ _ _ (CodeAction {_data_ = _}) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexepected argument for code action resolve handler: (Probably Nothing)" Nothing + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for code action resolve handler: (Probably Nothing)" Nothing -------------------------------------------------------------------------------- resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit @@ -244,10 +243,10 @@ data MinimalImportsResult = MinimalImportsResult forLens :: [(Range, Int)] -- |For the code actions we have the same data as for the code lenses, but -- we store it in a RangeMap, because that allows us to filter on a specific - -- range with better performance, and code actions are almost allways only + -- range with better performance, and code actions are almost always only -- requested for a specific range , forCodeActions :: RM.RangeMap (Range, Int) - -- |For resolve we have an intMap where for every previously provied unique id + -- |For resolve we have an intMap where for every previously provided unique id -- we provide a textEdit to allow our code actions or code lens to be resolved , forResolve :: IM.IntMap TextEdit } @@ -272,9 +271,9 @@ exportedModuleStrings _ = [] minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do -- Get the typechecking artifacts from the module - Just tmr <- use TypeCheck nfp + Just (tmr, tmrpm) <- useWithStale TypeCheck nfp -- We also need a GHC session with all the dependencies - Just hsc <- use GhcSessionDeps nfp + Just (hsc, _) <- useWithStale GhcSessionDeps nfp -- Use the GHC api to extract the "minimal" imports Just (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let importsMap = @@ -283,14 +282,16 @@ minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \Mi | L (locA -> RealSrcSpan l _) i <- mbMinImports ] res = - [ (realSrcSpanToRange l, minImport) - | i@(L _ imp) <- imports - , not (isQualifiedImport imp) - , not (isExplicitImport imp) - , let L _ mn = ideclName imp - , pred mn - , RealSrcSpan l _ <- [getLoc i] - , Just minImport <- [Map.lookup (realSrcSpanStart l) importsMap] + [ (newRange, minImport) + | imp@(L _ impDecl) <- imports + , not (isQualifiedImport impDecl) + , not (isExplicitImport impDecl) + , let L _ moduleName = ideclName impDecl + , pred moduleName + , RealSrcSpan location _ <- [getLoc imp] + , let range = realSrcSpanToRange location + , Just minImport <- [Map.lookup (realSrcSpanStart location) importsMap] + , Just newRange <- [toCurrentRange tmrpm range] ] uniqueAndRangeAndText <- liftIO $ for res $ \rt -> do u <- U.hashUnique <$> U.newUnique @@ -386,10 +387,6 @@ abbreviateImportTitle input = -------------------------------------------------------------------------------- --- | A helper to run ide actions -runIde :: IdeState -> Action a -> IO a -runIde = runAction "importLens" - within :: Range -> SrcSpan -> Bool within (Range start end) span = isInsideSrcSpan start span || isInsideSrcSpan end span From 58951746d86003174335722eac2440f66c3bc735 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 4 Jul 2023 15:35:32 +0300 Subject: [PATCH 10/15] Turn on -Werror and clean up var names --- .../hls-explicit-imports-plugin.cabal | 2 +- .../src/Ide/Plugin/ExplicitImports.hs | 59 ++++++++++--------- 2 files changed, 31 insertions(+), 30 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 4a72090807..ce17243f97 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -20,7 +20,7 @@ source-repository head location: https://github.com/haskell/haskell-language-server.git common warnings - ghc-options: -Wall + ghc-options: -Wall -Werror library import: warnings diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index a5625db21f..5f741ae3ce 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -43,7 +43,7 @@ import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding ((<+>)) import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Plugin.RangeMap (filterByRange) @@ -63,13 +63,13 @@ importCommandId = "ImportLensCommand" data Log = LogShake Shake.Log - | LogResponseError ResponseError + | LogWAEResponseError ResponseError deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log - LogResponseError msg -> pretty (show msg) + LogShake logMsg -> pretty logMsg + LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> viaShow rspErr -- | The "main" function of a plugin descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -83,13 +83,13 @@ descriptorForModules -- ^ Predicate to select modules that will be annotated -> PluginId -> PluginDescriptor IdeState -descriptorForModules recorder pred plId = +descriptorForModules recorder modFilter plId = (defaultPluginDescriptor plId) { -- This plugin provides a command handler pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)], -- This plugin defines a new rule - pluginRules = minimalImportsRule recorder pred, + pluginRules = minimalImportsRule recorder modFilter, pluginHandlers = -- This plugin provides code lenses mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) @@ -106,7 +106,7 @@ runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors return A.Null where logErrors (Left re@(ResponseError{})) = do - logWith recorder Error (LogResponseError re) + logWith recorder Error (LogWAEResponseError re) pure () logErrors (Right _) = pure () runImportCommand _ _ (ResolveAll _) = do @@ -128,9 +128,9 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { nfp <- getNormalizedFilePath _uri mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp case mbMinImports of - Just (MinimalImportsResult minImports _ _) -> do + Just (MinimalImportsResult{forLens}) -> do let lens = [ generateLens _uri range int - | (range, int) <- minImports] + | (range, int) <- forLens] pure $ InL lens _ -> pure $ InL [] @@ -144,15 +144,15 @@ lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeSta lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSON -> A.Success (ResolveOne uri uid))}) = pluginResponse $ do nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- + (MinimalImportsResult{forResolve}) <- handleMaybeM "Unable to run Minimal Imports" $ liftIO $ runAction "MinimalImports" ideState $ use MinimalImports nfp - target <- handleMaybe "Unable to resolve lens" $ resolveMinImp IM.!? uid - let updatedCodeLens = cl & L.command ?~ mkCommand plId target data_ + target <- handleMaybe "Unable to resolve lens" $ forResolve IM.!? uid + let updatedCodeLens = cl & L.command ?~ mkCommand plId target pure updatedCodeLens - where mkCommand :: PluginId -> TextEdit -> A.Value -> Command - mkCommand pId TextEdit{_newText} data_ = + where mkCommand :: PluginId -> TextEdit -> Command + mkCommand pId TextEdit{_newText} = let title = abbreviateImportTitle _newText _arguments = Just [data_] in mkLspCommand pId importCommandId title _arguments @@ -170,11 +170,11 @@ codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeStat codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) = pluginResponse $ do nfp <- getNormalizedFilePath _uri - (MinimalImportsResult _ minImports _) <- + (MinimalImportsResult{forCodeActions}) <- handleMaybeM "Unable to run Minimal Imports" $ liftIO $ runAction "MinimalImports" ideState $ use MinimalImports nfp - let relevantCodeActions = filterByRange range minImports + let relevantCodeActions = filterByRange range forCodeActions allExplicit = [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ResolveAll _uri) | not $ null relevantCodeActions ] @@ -206,19 +206,19 @@ codeActionResolveProvider _ _ _ (CodeAction {_data_ = _}) = do resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit resolveWTextEdit ideState (ResolveOne uri int) = do nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- + (MinimalImportsResult{forResolve}) <- handleMaybeM "Unable to run Minimal Imports" $ liftIO $ runAction "MinimalImports" ideState $ use MinimalImports nfp - tedit <- handleMaybe "Unable to resolve text edit" $ resolveMinImp IM.!? int + tedit <- handleMaybe "Unable to resolve text edit" $ forResolve IM.!? int pure $ mkWorkspaceEdit uri [tedit] resolveWTextEdit ideState (ResolveAll uri) = do nfp <- getNormalizedFilePath uri - (MinimalImportsResult _ _ resolveMinImp) <- + (MinimalImportsResult{forResolve}) <- handleMaybeM "Unable to run Minimal Imports" $ liftIO $ runAction "MinimalImports" ideState $ use MinimalImports nfp - let edits = IM.elems resolveMinImp + let edits = IM.elems forResolve pure $ mkWorkspaceEdit uri edits mkWorkspaceEdit :: Uri -> [TextEdit] -> WorkspaceEdit @@ -269,7 +269,7 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} exportedModuleStrings _ = [] minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () -minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do +minimalImportsRule recorder modFilter = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do -- Get the typechecking artifacts from the module Just (tmr, tmrpm) <- useWithStale TypeCheck nfp -- We also need a GHC session with all the dependencies @@ -287,7 +287,7 @@ minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \Mi , not (isQualifiedImport impDecl) , not (isExplicitImport impDecl) , let L _ moduleName = ideclName impDecl - , pred moduleName + , modFilter moduleName , RealSrcSpan location _ <- [getLoc imp] , let range = realSrcSpanToRange location , Just minImport <- [Map.lookup (realSrcSpanStart location) importsMap] @@ -298,9 +298,9 @@ minimalImportsRule recorder pred = define (cmapWithPrio LogShake recorder) $ \Mi pure (u, rt) let rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] return ([], Just $ MinimalImportsResult - rangeAndUnique - (RM.fromList fst rangeAndUnique) - (IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText))) + { forLens = rangeAndUnique + , forCodeActions = RM.fromList fst rangeAndUnique + , forResolve = IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText) }) -------------------------------------------------------------------------------- @@ -315,7 +315,7 @@ extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do (_, imports, _, _) = tmrRenamed ParsedModule {pm_parsed_source = L loc _} = tmrParsed emss = exportedModuleStrings tmrParsed - Just span <- pure $ realSpan loc + Just srcSpan <- pure $ realSpan loc -- Don't make suggestions for modules which are also exported, the user probably doesn't want this! -- See https://github.com/haskell/haskell-language-server/issues/2079 let notExportedImports = filter (notExported emss) imports @@ -327,7 +327,7 @@ extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do -- GHC is full of treats like this let usage = findImportUsage notExportedImports gblElts (_, Just minimalImports) <- liftIO $ - initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage + initTcWithGbl (hscEnv hsc) tcEnv srcSpan $ getMinimalImports usage -- return both the original imports and the computed minimal ones return (imports, minimalImports) @@ -375,6 +375,7 @@ abbreviateImportTitle input = numAdditionalItems = T.count "," actualSuffix + 1 -- We want to make text like this: import Foo (AImport, BImport, ... (30 items)) -- We also want it to look sensible if we end up splitting in the module name itself, + summaryText :: Int -> T.Text summaryText n = " ... (" <> fromString (show n) <> " items)" -- so we only add a trailing paren if we've split in the export list suffixText = summaryText numAdditionalItems <> if T.count "(" prefix > 0 then ")" else "" @@ -388,5 +389,5 @@ abbreviateImportTitle input = -------------------------------------------------------------------------------- within :: Range -> SrcSpan -> Bool -within (Range start end) span = - isInsideSrcSpan start span || isInsideSrcSpan end span +within (Range start end) srcSpan = + isInsideSrcSpan start srcSpan || isInsideSrcSpan end srcSpan From c778379bfa410e545a57870b6c13d1fb7d60accf Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 4 Jul 2023 16:06:52 +0300 Subject: [PATCH 11/15] Fix test warnings --- .../hls-explicit-imports-plugin/test/Main.hs | 25 ++++++------------- 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index a16b203eac..dd5beb531d 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -9,21 +9,18 @@ module Main ) where import Control.Lens ((^.)) -import Data.Foldable (find, forM_) +import Data.Foldable (find) import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.ExplicitImports as ExplicitImports import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import System.FilePath ((<.>), ()) +import System.FilePath (()) import Test.Hls explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports" -longModule :: T.Text -longModule = "F" <> T.replicate 80 "o" - main :: IO () main = defaultTestRunner $ testGroup @@ -80,7 +77,7 @@ codeActionAllGoldenTest fp l c = goldenWithExplicitImports " code action" fp cod codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree codeActionAllResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do actions <- getCodeActions doc (pointRange l c) - let Just (InR x) = find ((== Just "Make all imports explicit") . caTitle) actions + Just (InR x) <- pure $ find ((== Just "Make all imports explicit") . caTitle) actions resolved <- resolveCodeAction x executeCodeAction resolved @@ -94,14 +91,14 @@ codeActionOnlyGoldenTest fp l c = goldenWithExplicitImports " code action" fp co codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree codeActionOnlyResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do actions <- getCodeActions doc (pointRange l c) - let Just (InR x) = find ((== Just "Make this import explicit") . caTitle) actions + Just (InR x) <- pure $ find ((== Just "Make this import explicit") . caTitle) actions resolved <- resolveCodeAction x executeCodeAction resolved resolveCodeAction :: CodeAction -> Session CodeAction resolveCodeAction ca = do resolveResponse <- request SMethod_CodeActionResolve ca - let Right resolved = resolveResponse ^. L.result + Right resolved <- pure $ resolveResponse ^. L.result pure resolved caTitle :: (Command |? CodeAction) -> Maybe Text @@ -111,7 +108,7 @@ caTitle _ = Nothing -- code lens tests codeLensGoldenTest :: FilePath -> Int -> TestTree -codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports " code lens" fp codeActionNoResolveCaps $ \doc -> do +codeLensGoldenTest fp _ = goldenWithExplicitImports " code lens" fp codeActionNoResolveCaps $ \doc -> do (codeLens: _) <- getCodeLenses doc CodeLens {_command = Just c} <- resolveCodeLens codeLens executeCmd c @@ -119,17 +116,9 @@ codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports " code lens" fp co resolveCodeLens :: CodeLens -> Session CodeLens resolveCodeLens cl = do resolveResponse <- request SMethod_CodeLensResolve cl - let Right resolved = resolveResponse ^. L.result + Right resolved <- pure $ resolveResponse ^. L.result pure resolved -getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] -getCodeLensesBy f doc = filter f <$> getCodeLenses doc - -isExplicitImports :: CodeLens -> Bool -isExplicitImports (CodeLens _ (Just (Command _ cmd _)) _) - | ":explicitImports:" `T.isInfixOf` cmd = True -isExplicitImports _ = False - -- Execute command and wait for result executeCmd :: Command -> Session () executeCmd cmd = do From df8fda0bd5bd2af9e6d4c9c8c289c0dc387539be Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 4 Jul 2023 15:19:48 +0000 Subject: [PATCH 12/15] Move to maybeT and fix 8.10 flags issue --- .../src/Ide/Plugin/ExplicitImports.hs | 23 +++++++++++-------- .../hls-refine-imports-plugin.cabal | 1 + .../src/Ide/Plugin/RefineImports.hs | 19 ++++++++------- 3 files changed, 25 insertions(+), 18 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 5f741ae3ce..c247ceff00 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -122,7 +122,7 @@ runImportCommand _ _ (ResolveAll _) = do -- the provider should produce one code lens associated to the import statement: -- -- > import Data.List (intercalate, sortBy) -lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens +lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = pluginResponse $ do nfp <- getNormalizedFilePath _uri @@ -140,7 +140,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { , _range = range , _command = Nothing } -lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeLensResolve +lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeLensResolve lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSON -> A.Success (ResolveOne uri uid))}) = pluginResponse $ do nfp <- getNormalizedFilePath uri @@ -166,7 +166,7 @@ lensResolveProvider _ _ _ (CodeLens {_data_ = _}) = do -- | If there are any implicit imports, provide both one code action per import -- to make that specific import explicit, and one code action to turn them all -- into explicit imports. -codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) = pluginResponse $ do nfp <- getNormalizedFilePath _uri @@ -192,7 +192,7 @@ codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier , _disabled = Nothing , _data_ = data_} -codeActionResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeActionResolve +codeActionResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeActionResolve codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON -> A.Success rd)}) = pluginResponse $ do wedit <- resolveWTextEdit ideState rd @@ -269,13 +269,13 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} exportedModuleStrings _ = [] minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () -minimalImportsRule recorder modFilter = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do +minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> runMaybeT $ do -- Get the typechecking artifacts from the module - Just (tmr, tmrpm) <- useWithStale TypeCheck nfp + (tmr, tmrpm) <- MaybeT $ useWithStale TypeCheck nfp -- We also need a GHC session with all the dependencies - Just (hsc, _) <- useWithStale GhcSessionDeps nfp + (hsc, _) <- MaybeT $ useWithStale GhcSessionDeps nfp -- Use the GHC api to extract the "minimal" imports - Just (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, mbMinImports) <- MaybeT $ liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList [ (realSrcSpanStart l, printOutputable i) @@ -297,10 +297,10 @@ minimalImportsRule recorder modFilter = define (cmapWithPrio LogShake recorder) u <- U.hashUnique <$> U.newUnique pure (u, rt) let rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] - return ([], Just $ MinimalImportsResult + pure MinimalImportsResult { forLens = rangeAndUnique , forCodeActions = RM.fromList fst rangeAndUnique - , forResolve = IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText) }) + , forResolve = IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText) } -------------------------------------------------------------------------------- @@ -336,6 +336,9 @@ extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do notExported [] _ = True notExported exports (L _ ImportDecl{ideclName = L _ name}) = not $ any (\e -> ("module " ++ moduleNameString name) == e) exports +#if !MIN_VERSION_ghc (9,0,0) + notExported _ _ = True +#endif isExplicitImport :: ImportDecl GhcRn -> Bool #if MIN_VERSION_ghc (9,5,0) diff --git a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal index 2145fe6a2a..2011f74b37 100644 --- a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal +++ b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal @@ -35,6 +35,7 @@ library , hls-plugin-api == 2.1.0.0 , lsp , text + , transformers , unordered-containers default-language: Haskell2010 diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index b8620ea6ce..e8b3ad9af2 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -15,6 +15,9 @@ import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) import Control.Monad (join) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + runMaybeT) import Data.Aeson.Types import Data.IORef (readIORef) import Data.List (intercalate) @@ -184,28 +187,28 @@ instance Show RefineImportsResult where show _ = "" instance NFData RefineImportsResult where rnf = rwhnf refineImportsRule :: Recorder (WithPriority Log) -> Rules () -refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> do +refineImportsRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> runMaybeT $ do -- Get the typechecking artifacts from the module - Just tmr <- use TypeCheck nfp + tmr <- MaybeT $ use TypeCheck nfp -- We also need a GHC session with all the dependencies - Just hsc <- use GhcSessionDeps nfp + hsc <- MaybeT $ use GhcSessionDeps nfp -- 2 layer map ModuleName -> ModuleName -> [Avails] (exports) import2Map <- do -- first layer is from current(editing) module to its imports - ImportMap currIm <- use_ GetImportMap nfp + ImportMap currIm <- lift $ use_ GetImportMap nfp forM currIm $ \path -> do -- second layer is from the imports of first layer to their imports - ImportMap importIm <- use_ GetImportMap path + ImportMap importIm <- lift $ use_ GetImportMap path forM importIm $ \imp_path -> do - imp_hir <- use_ GetModIface imp_path + imp_hir <- lift $ use_ GetModIface imp_path return $ mi_exports $ hirModIface imp_hir -- Use the GHC api to extract the "minimal" imports -- We shouldn't blindly refine imports -- instead we should generate imports statements -- for modules/symbols actually got used - Just (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, mbMinImports) <- MaybeT $ liftIO $ extractMinimalImports hsc tmr let filterByImport :: LImportDecl GhcRn @@ -268,7 +271,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -- if no symbols from this modules then don't need to generate new import , not $ null filteredInnerImports ] - return ([], Just $ RefineImportsResult res) + pure $ RefineImportsResult res where -- Check if a name is exposed by AvailInfo (the available information of a module) From b86b156409561579fbac4bb8850450a06cdad80b Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 4 Jul 2023 18:29:23 +0300 Subject: [PATCH 13/15] Added stale action test --- .../hls-explicit-imports-plugin.cabal | 1 + plugins/hls-explicit-imports-plugin/test/Main.hs | 15 +++++++++++++++ .../test/testdata/StaleAction.expected.hs | 6 ++++++ .../test/testdata/StaleAction.hs | 6 ++++++ .../test/testdata/hie.yaml | 1 + 5 files changed, 29 insertions(+) create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index ce17243f97..a5702aa394 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -62,4 +62,5 @@ test-suite tests , hls-test-utils , lens , lsp-types + , row-types , text diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index dd5beb531d..14a330cc04 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -10,6 +11,7 @@ module Main import Control.Lens ((^.)) import Data.Foldable (find) +import Data.Row ((.+), (.==)) import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.ExplicitImports as ExplicitImports @@ -30,6 +32,7 @@ main = defaultTestRunner $ , codeActionOnlyGoldenTest "OnlyThis" 3 0 , codeActionOnlyResolveGoldenTest "OnlyThis" 3 0 , codeLensGoldenTest "UsualCase" 0 + , codeActionBreakFile "StaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer explicitImportsPlugin testDataDir $ do doc <- openDoc "Exported.hs" "haskell" @@ -74,6 +77,18 @@ codeActionAllGoldenTest fp l c = goldenWithExplicitImports " code action" fp cod Just (InR x) -> executeCodeAction x _ -> liftIO $ assertFailure "Unable to find CodeAction" +codeActionBreakFile :: FilePath -> Int -> Int -> TestTree +codeActionBreakFile fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + _ <- waitForDiagnostics + changeDoc doc [edit] + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make all imports explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== pointRange 2 21 + .+ #rangeLength .== Nothing + .+ #text .== "x" + codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree codeActionAllResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do actions <- getCodeActions doc (pointRange l c) diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs new file mode 100644 index 0000000000..5727f390ae --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module StaleAction wxere + +import A ( a1 ) + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs new file mode 100644 index 0000000000..6d38cc62c4 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module StaleAction where + +import A + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml index fe43a0712d..8d08bfb527 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml +++ b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml @@ -3,6 +3,7 @@ cradle: direct: arguments: - OnlyThis.hs + - StaleAction.hs - UsualCase.hs - Exported.hs - A.hs From 905edd3b3af4c67f07070039d87a25fba7c0336c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 10 Jul 2023 22:01:16 +0300 Subject: [PATCH 14/15] Address suggestions --- .../hls-explicit-imports-plugin.cabal | 13 ++++++-- .../src/Ide/Plugin/ExplicitImports.hs | 8 ++--- .../hls-explicit-imports-plugin/test/Main.hs | 30 +++++++++++++++++-- .../test/testdata/BreakFile.expected.hs | 6 ++++ .../test/testdata/BreakFile.hs | 6 ++++ .../test/testdata/StaleAction.expected.hs | 6 ++-- 6 files changed, 59 insertions(+), 10 deletions(-) create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs create mode 100644 plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index a5702aa394..0b0f818922 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -19,8 +19,13 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git +flag pedantic + description: Enable -Werror + default: False + manual: True + common warnings - ghc-options: -Wall -Werror + ghc-options: -Wall library import: warnings @@ -47,6 +52,9 @@ library DataKinds TypeOperators + if flag(pedantic) + ghc-options: -Werror + test-suite tests import: warnings buildable: True @@ -57,10 +65,11 @@ test-suite tests ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , base + , extra , filepath , hls-explicit-imports-plugin , hls-test-utils , lens , lsp-types , row-types - , text + , text \ No newline at end of file diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index c247ceff00..475731c321 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -160,8 +160,8 @@ lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON -> A.Success (Re pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: ResolveAll" Nothing lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON @EIResolveData -> (A.Error (T.pack -> str)))}) = pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing -lensResolveProvider _ _ _ (CodeLens {_data_ = _}) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: (Probably Nothing)" Nothing +lensResolveProvider _ _ _ (CodeLens {_data_ = v}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Unexpected argument for lens resolve handler: " <> (T.pack $ show v)) Nothing -- | If there are any implicit imports, provide both one code action per import -- to make that specific import explicit, and one code action to turn them all @@ -199,8 +199,8 @@ codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON - pure $ ca & L.edit ?~ wedit codeActionResolveProvider _ _ _ (CodeAction{_data_= Just (A.fromJSON @EIResolveData -> A.Error (T.pack -> str))}) = pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing -codeActionResolveProvider _ _ _ (CodeAction {_data_ = _}) = do - pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for code action resolve handler: (Probably Nothing)" Nothing +codeActionResolveProvider _ _ _ (CodeAction {_data_ = v}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Unexpected argument for code action resolve handler: " <> (T.pack $ show v)) Nothing -------------------------------------------------------------------------------- resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 14a330cc04..d787630b7f 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - module Main ( main ) where import Control.Lens ((^.)) +import Data.Either.Extra import Data.Foldable (find) import Data.Row ((.+), (.==)) import Data.Text (Text) @@ -32,7 +33,8 @@ main = defaultTestRunner $ , codeActionOnlyGoldenTest "OnlyThis" 3 0 , codeActionOnlyResolveGoldenTest "OnlyThis" 3 0 , codeLensGoldenTest "UsualCase" 0 - , codeActionBreakFile "StaleAction" 4 0 + , codeActionBreakFile "BreakFile" 4 0 + , codeActionStaleAction "StaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer explicitImportsPlugin testDataDir $ do doc <- openDoc "Exported.hs" "haskell" @@ -89,6 +91,22 @@ codeActionBreakFile fp l c = goldenWithExplicitImports " code action" fp codeAct .+ #rangeLength .== Nothing .+ #text .== "x" +codeActionStaleAction :: FilePath -> Int -> Int -> TestTree +codeActionStaleAction fp l c = goldenWithExplicitImports " code action" fp codeActionResolveCaps $ \doc -> do + _ <- waitForDiagnostics + actions <- getCodeActions doc (pointRange l c) + changeDoc doc [edit] + _ <- waitForDiagnostics + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> + maybeResolveCodeAction x >>= + \case Just _ -> liftIO $ assertFailure "Code action still valid" + Nothing -> pure () + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0) + .+ #rangeLength .== Nothing + .+ #text .== "\ntesting = undefined" + codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree codeActionAllResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do actions <- getCodeActions doc (pointRange l c) @@ -110,12 +128,19 @@ codeActionOnlyResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolved <- resolveCodeAction x executeCodeAction resolved +-- TODO: use the one from lsp-test once that's released resolveCodeAction :: CodeAction -> Session CodeAction resolveCodeAction ca = do resolveResponse <- request SMethod_CodeActionResolve ca Right resolved <- pure $ resolveResponse ^. L.result pure resolved +maybeResolveCodeAction :: CodeAction -> Session (Maybe CodeAction) +maybeResolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + let resolved = resolveResponse ^. L.result + pure $ eitherToMaybe resolved + caTitle :: (Command |? CodeAction) -> Maybe Text caTitle (InR CodeAction {_title}) = Just _title caTitle _ = Nothing @@ -128,6 +153,7 @@ codeLensGoldenTest fp _ = goldenWithExplicitImports " code lens" fp codeActionNo CodeLens {_command = Just c} <- resolveCodeLens codeLens executeCmd c +-- TODO: use the one from lsp-test once that's released resolveCodeLens :: CodeLens -> Session CodeLens resolveCodeLens cl = do resolveResponse <- request SMethod_CodeLensResolve cl diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs new file mode 100644 index 0000000000..6ef3eeec69 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module BreakFile whexe + +import A ( a1 ) + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs new file mode 100644 index 0000000000..2a570ae2d8 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module BreakFile where + +import A + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs index 5727f390ae..a345a5c91e 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} -module StaleAction wxere +module StaleAction where -import A ( a1 ) +import A main = putStrLn $ "hello " ++ a1 + +testing = undefined \ No newline at end of file From 3f7f55c4477a7a6c5177870fbee4995ccb8c807a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 11 Jul 2023 17:49:41 +0300 Subject: [PATCH 15/15] fix merge mistake --- .../src/Ide/Plugin/ExplicitImports.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index c96b71a31b..c99ff2ee1d 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -27,7 +27,6 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe import qualified Data.Aeson as A (Result (..), ToJSON (toJSON), - Value (), fromJSON) import Data.Aeson.Types (FromJSON) import qualified Data.IntMap as IM (IntMap, elems, @@ -104,7 +103,7 @@ runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIRe runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do wedit <- resolveWTextEdit ideState eird _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors - return InR $ Null + return $ InR Null where logErrors (Left re@(ResponseError{})) = do logWith recorder Error (LogWAEResponseError re) pure ()