From 0443319f76798c8eb426c08f73d2c7367f44f28d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 5 Jul 2023 23:42:07 +0300 Subject: [PATCH 01/14] WIP --- hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Plugin/Resolve.hs | 108 +++++++++++ hls-plugin-api/src/Ide/Types.hs | 231 +++++++++-------------- 3 files changed, 194 insertions(+), 146 deletions(-) create mode 100644 hls-plugin-api/src/Ide/Plugin/Resolve.hs diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 64d1aa8263..4a4c370f5d 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -38,6 +38,7 @@ library Ide.Plugin.ConfigUtils Ide.Plugin.Properties Ide.Plugin.RangeMap + Ide.Plugin.Resolve Ide.PluginUtils Ide.Types diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs new file mode 100644 index 0000000000..7e477e180b --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve, +mkCodeActionWithResolveAndCommand) where + +import Control.Lens (_Just, (&), (.~), (?~), (^?)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.Aeson (ToJSON (toJSON)) +import qualified Data.Aeson +import Data.Row ((.!)) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server (LspM, LspT, + ProgressCancellable (Cancellable), + getClientCapabilities, + sendRequest, + withIndefiniteProgress) + + -- |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 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 + supportsCodeActionResolve caps -> pure $ InL 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 + in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkPluginHandler SMethod_CodeActionResolve codeResolveMethod + where + 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 + +-- |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. + PluginId + -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) + -> ([PluginCommand ideState], PluginHandlers ideState) +mkCodeActionWithResolveAndCommand plId 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 + supportsCodeActionResolve caps -> + pure $ InL ls + -- If they do not we will drop the data field, in addition we will populate the command + -- field with our command to execute the resolve, with the whole code action as it's argument. + | otherwise -> pure $ InL $ moveDataToCommand <$> ls + in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd plId codeResolveMethod)], + mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkPluginHandler SMethod_CodeActionResolve codeResolveMethod) + where moveDataToCommand :: Command |? CodeAction -> Command |? CodeAction + moveDataToCommand ca = + let dat = toJSON <$> ca ^? _R -- We need to take the whole codeAction + -- And put it in the argument for the Command, that way we can later + -- pas it to the resolve handler (which expects a whole code action) + cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat) + in ca + & _R . L.data_ .~ Nothing -- Set the data field to nothing + & _R . L.command ?~ cmd -- And set the command to our previously created command + executeResolveCmd :: PluginId -> PluginMethodHandler ideState Method_CodeActionResolve -> CommandFunction ideState CodeAction + executeResolveCmd pluginId resolveProvider ideState ca = do + withIndefiniteProgress "Executing code action..." Cancellable $ do + resolveResult <- resolveProvider ideState pluginId ca + case resolveResult of + Right CodeAction {_edit = Just wedits } -> do + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) + pure $ Right Data.Aeson.Null + Right _ -> pure $ Left $ responseError "No edit in CodeAction" + Left err -> pure $ Left err + +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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index b7aaa6e231..195b6b2c2b 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -48,9 +48,7 @@ module Ide.Types , installSigUsr1Handler , responseError , lookupCommandProvider -, OwnedResolveData(..) -, mkCodeActionHandlerWithResolve -, mkCodeActionWithResolveAndCommand +, PluginResolveData(..) ) where @@ -64,10 +62,7 @@ import System.Posix.Signals import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Lens (_Just, (.~), (?~), (^.), (^?)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson hiding (Null, defaultOptions) -import qualified Data.Aeson import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap @@ -81,7 +76,6 @@ 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 @@ -93,11 +87,7 @@ 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, LspT, - ProgressCancellable (Cancellable), - getClientCapabilities, - getVirtualFile, sendRequest, - withIndefiniteProgress) +import Language.LSP.Server (LspM, LspT, getVirtualFile) import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog @@ -477,7 +467,9 @@ instance PluginMethod Request Method_TextDocumentDocumentSymbol where uri = msgParams ^. L.textDocument . L.uri instance PluginMethod Request Method_CompletionItemResolve where - pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) + pluginEnabled _ msgParams pluginDesc config = + pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) instance PluginMethod Request Method_TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc @@ -558,9 +550,8 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where | 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) + -- Resolve method should only ever get one response + combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x @@ -624,16 +615,8 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where in [si] <> children' instance PluginRequestMethod Method_CompletionItemResolve where - -- resolving completions can only change the detail, additionalTextEdit or documentation fields - combineResponses _ _ _ _ (x :| xs) = go x xs - where go :: CompletionItem -> [CompletionItem] -> CompletionItem - go !comp [] = comp - go !comp1 (comp2:xs) - = go (comp1 - & L.detail .~ comp1 ^. L.detail <> comp2 ^. L.detail - & L.documentation .~ ((comp1 ^. L.documentation) <|> (comp2 ^. L.documentation)) -- difficult to write generic concatentation for docs - & L.additionalTextEdits .~ comp1 ^. L.additionalTextEdits <> comp2 ^. L.additionalTextEdits) - xs + -- resolve method's should only ever get one response + combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs @@ -792,13 +775,71 @@ type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams -- | Make a handler for plugins with no extra data mkPluginHandler - :: PluginRequestMethod m + :: forall ideState m. PluginRequestMethod m => SClientMethod m -> PluginMethodHandler ideState m -> PluginHandlers ideState -mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f') +mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m)) where - f' pid ide params = pure <$> f ide pid params + f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either ResponseError (MessageResult m))) + -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions + -- CodeLens, and Completion methods. + f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} = + pure . fmap (wrapCodeActions pid _uri) <$> f ide pid params + f' SMethod_TextDocumentCodeLens pid ide params@CodeLensParams{_textDocument=TextDocumentIdentifier {_uri}} = + pure . fmap (wrapCodeLenses pid _uri) <$> f ide pid params + f' SMethod_TextDocumentCompletion pid ide params@CompletionParams{_textDocument=TextDocumentIdentifier {_uri}} = + pure . fmap (wrapCompletions pid _uri) <$> f ide pid params + + -- If resolve handlers aren't declared with mkPluginHandler we won't need these here anymore + f' SMethod_CodeActionResolve pid ide params = + pure <$> f ide pid (unwrapResolveData params) + f' SMethod_CodeLensResolve pid ide params = + pure <$> f ide pid (unwrapResolveData params) + f' SMethod_CompletionItemResolve pid ide params = + pure <$> f ide pid (unwrapResolveData params) + + -- This is the default case for all other methods + f' _ pid ide params = pure <$> f ide pid params + + -- Todo: use fancy pancy lenses to make this a few lines + wrapCodeActions pid uri (InL ls) = + let wrapCodeActionItem pid uri (InR c) = InR $ wrapResolveData pid uri c + wrapCodeActionItem _ _ command@(InL _) = command + in InL $ wrapCodeActionItem pid uri <$> ls + wrapCodeActions _ _ (InR r) = InR r + + wrapCodeLenses pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls + wrapCodeLenses _ _ (InR r) = InR r + + wrapCompletions pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls + wrapCompletions pid uri (InR (InL cl@(CompletionList{_items}))) = + InR $ InL $ cl & L.items .~ (wrapResolveData pid uri <$> _items) + wrapCompletions _ _ (InR (InR r)) = InR $ InR r + +wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a +wrapResolveData pid uri hasData = + hasData & L.data_ .~ (toJSON .PRD pid uri <$> data_) + where data_ = hasData ^? L.data_ . _Just + +unwrapResolveData :: L.HasData_ a (Maybe Value) => a -> a +unwrapResolveData hasData + | Just x <- hasData ^. L.data_ + , Success PRD {value = v} <- fromJSON x = hasData & L.data_ ?~ v +-- If we can't successfully decode the value as a ORD type than +-- we just return the type 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 PluginResolveData = PRD { + owner :: PluginId +, uri :: Uri +, value :: Value +} deriving (Generic, Show) +instance ToJSON PluginResolveData +instance FromJSON PluginResolveData -- | Make a handler for plugins with no extra data mkPluginNotificationHandler @@ -877,6 +918,17 @@ type CommandFunction ideState a -- --------------------------------------------------------------------- +-- Will something like this work? +type ResolveFunction ideState a m + = ideState + -> PluginId + -> MessageParams m + -> Uri + -> a + -> LspM Config (Either ResponseError (MessageResult m)) + + + newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) deriving newtype (ToJSON, FromJSON, Hashable) @@ -1016,124 +1068,11 @@ 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 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 - 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 (unwrapCodeActionResolveData params) - in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod - where - 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 - --- |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. - PluginId - -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) - -> ([PluginCommand ideState], PluginHandlers ideState) -mkCodeActionWithResolveAndCommand plId 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 - supportsCodeActionResolve caps -> - pure $ InL (wrapCodeActionResolveData pid <$> ls) - -- If they do not we will drop the data field, in addition we will populate the command - -- field with our command to execute the resolve, with the whole code action as it's argument. - | otherwise -> pure $ InL $ moveDataToCommand <$> ls - newCodeResolveMethod ideState pid params = - codeResolveMethod ideState pid (unwrapCodeActionResolveData params) - in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd plId codeResolveMethod)], - mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod) - where moveDataToCommand :: Command |? CodeAction -> Command |? CodeAction - moveDataToCommand ca = - let dat = toJSON <$> ca ^? _R -- We need to take the whole codeAction - -- And put it in the argument for the Command, that way we can later - -- pas it to the resolve handler (which expects a whole code action) - cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat) - in ca - & _R . L.data_ .~ Nothing -- Set the data field to nothing - & _R . L.command ?~ cmd -- And set the command to our previously created command - executeResolveCmd :: PluginId -> PluginMethodHandler ideState Method_CodeActionResolve -> CommandFunction ideState CodeAction - executeResolveCmd pluginId resolveProvider ideState ca = do - withIndefiniteProgress "Executing code action..." Cancellable $ do - resolveResult <- resolveProvider ideState pluginId ca - case resolveResult of - Right CodeAction {_edit = Just wedits } -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right Data.Aeson.Null - Right _ -> pure $ Left $ responseError "No edit in CodeAction" - Left err -> pure $ Left err - -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 --- 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 + (Success (PRD o _ _)) -> pluginId pluginDesc == o + _ -> False -- If we can't decode the data, something is seriously wrong +-- If there is no data stored, than we can't resolve it +pluginResolverResponsible Nothing _ = False From b1d666e7d7a56d5039f27c662d1619dc3ca05260 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 7 Jul 2023 20:38:57 +0300 Subject: [PATCH 02/14] Separate resolve logic from method handling --- .../src/Development/IDE/Plugin/Completions.hs | 12 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 64 ++++++++ hls-plugin-api/src/Ide/Plugin/Resolve.hs | 107 +++++++++---- hls-plugin-api/src/Ide/Types.hs | 146 +++++++++--------- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 22 ++- .../src/Ide/Plugin/OverloadedRecordDot.hs | 39 +++-- 6 files changed, 247 insertions(+), 143 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 2a1841131c..9bcf77a2fb 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -66,7 +66,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP - <> mkPluginHandler SMethod_CompletionItemResolve resolveCompletion + , pluginResolveHandlers = mkResolveHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } @@ -119,11 +119,9 @@ dropListFromImportDecl iDecl = let f x = x in f <$> iDecl -resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) -resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_data_} - | Just resolveData <- _data_ - , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData - , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri +resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve +resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) + | Just file <- uriToNormalizedFilePath $ toNormalizedUri uri = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do msess <- useWithStaleFast GhcSessionDeps file case msess of @@ -160,7 +158,7 @@ resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_data_} where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -resolveCompletion _ _ comp = pure (Right comp) +resolveCompletion _ _ _ _ _ = pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unable to get normalized file path for url" Nothing -- | Generate code actions. getCompletionsLSP diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index c134a26045..ad8054cad3 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -54,12 +54,16 @@ data Log = LogPluginError PluginId ResponseError | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier + | LogNoResolveData + | LogParseError String (Maybe A.Value) instance Pretty Log where pretty = \case LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" + LogNoResolveData -> "No resolve data in resolve request" + LogParseError msg value -> "Error while parsing: " <> pretty msg <> ", value = " <> viaShow value instance Show Log where show = renderString . layoutCompact . pretty @@ -99,11 +103,19 @@ logAndReturnError recorder p errCode msg = do logWith recorder Warning $ LogPluginError p err pure $ Left err +-- | Build a ResponseError and log it before returning to the caller +logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError' recorder errCode msg = do + let err = ResponseError errCode (T.pack $ show msg) Nothing + logWith recorder Warning $ msg + pure $ Left err + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <> + mkPlugin (extensibleResolvePlugins recorder) id <> mkPlugin (extensiblePlugins recorder) id <> mkPlugin (extensibleNotificationPlugins recorder) id <> mkPluginFromDescriptor dynFlagsPlugins HLS.pluginModifyDynflags @@ -201,6 +213,46 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- --------------------------------------------------------------------- +extensibleResolvePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config +extensibleResolvePlugins recorder xs = mempty { P.pluginHandlers = handlers } + where + IdeResolveHandlers handlers' = foldMap bakePluginId xs + bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeResolveHandlers + bakePluginId (pid,pluginDesc) = IdeResolveHandlers $ DMap.map + (\f -> IdeResolveHandler [(pid,pluginDesc,f)]) + hs + where + PluginResolveHandlers hs = HLS.pluginResolveHandlers pluginDesc + handlers = mconcat $ do + (ResolveMethod m :=> IdeResolveHandler fs') <- DMap.assocs handlers' + pure $ requestHandler m $ \ide params -> do + case A.fromJSON <$> (params ^. L.data_) of + (Just (A.Success (HLS.PluginResolveData owner uri value) )) -> do + -- Only run plugins that are allowed to run on this request + let fs = filter (\(pid,_ , _) -> pid == owner) fs' + -- Clients generally don't display ResponseErrors so instead we log any that we come across + case nonEmpty fs of + Nothing -> do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing + msg = pluginNotEnabled m fs' + return $ Left err + Just ((pid, _, ResolveHandler handler) NE.:| _) -> do + let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) + case A.fromJSON value of + A.Success decodedValue -> do + otTracedProvider pid (fromString $ show m) $ do + handler ide pid params uri decodedValue + `catchAny` (\e -> pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg e pid) Nothing) + A.Error err -> do + logAndReturnError' recorder (InR ErrorCodes_ParseError) (LogParseError err (Just value)) + + Nothing -> do + logAndReturnError' recorder (InR ErrorCodes_InvalidParams) LogNoResolveData + (Just (A.Error str)) -> do + logAndReturnError' recorder (InR ErrorCodes_ParseError) (LogParseError str (params ^. L.data_)) +-- --------------------------------------------------------------------- + extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } where @@ -286,6 +338,10 @@ combineErrors xs = ResponseError (InR ErrorCodes_InternalError) (T.pack (show x newtype IdeHandler (m :: Method ClientToServer Request) = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (MessageResult m))))] +newtype IdeResolveHandler (m :: Method ClientToServer Request) + = IdeResolveHandler [(PluginId, PluginDescriptor IdeState, PluginResolveHandler IdeState m)] + + -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: Method ClientToServer Notification) = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] @@ -293,6 +349,7 @@ newtype IdeNotificationHandler (m :: Method ClientToServer Notification) -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) +newtype IdeResolveHandlers = IdeResolveHandlers (DMap ResolveMethod IdeResolveHandler) newtype IdeNotificationHandlers = IdeNotificationHandlers (DMap IdeNotification IdeNotificationHandler) instance Semigroup IdeHandlers where @@ -302,6 +359,13 @@ instance Semigroup IdeHandlers where instance Monoid IdeHandlers where mempty = IdeHandlers mempty +instance Semigroup IdeResolveHandlers where + (IdeResolveHandlers a) <> (IdeResolveHandlers b) = IdeResolveHandlers $ DMap.unionWithKey go a b + where + go _ (IdeResolveHandler a) (IdeResolveHandler b) = IdeResolveHandler (a <> b) +instance Monoid IdeResolveHandlers where + mempty = IdeResolveHandlers mempty + instance Semigroup IdeNotificationHandlers where (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b where diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 7e477e180b..7d2fe74d4b 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,12 +8,15 @@ module Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve, mkCodeActionWithResolveAndCommand) where -import Control.Lens (_Just, (&), (.~), (?~), (^?)) +import Control.Lens (_Just, (&), (.~), (?~), (^.), + (^?)) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Aeson (ToJSON (toJSON)) -import qualified Data.Aeson +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, + throwE) +import qualified Data.Aeson as A import Data.Row ((.!)) +import qualified Data.Text as T +import GHC.Generics (Generic) import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -29,9 +33,10 @@ import Language.LSP.Server (LspM, LspT, -- 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 + :: forall ideState a. (A.FromJSON a) => + (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) + -> (PluginHandlers ideState, PluginResolveHandlers ideState) mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = runExceptT $ do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params @@ -42,16 +47,24 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = -- resolve data type to allow the server to know who to send the resolve request to supportsCodeActionResolve caps -> pure $ InL 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 - in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkPluginHandler SMethod_CodeActionResolve codeResolveMethod + | otherwise -> InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls + in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + , mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where 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 + resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) + resolveCodeAction _uri _ideState _plId c@(InL _) = pure c + resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do + case A.fromJSON value of + A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Success innerValueDecoded -> do + resolveResult <- ExceptT $ codeResolveMethod ideState pid codeAction uri innerValueDecoded + case resolveResult of + CodeAction {_edit = Just _ } -> do + pure $ InR $ dropData resolveResult + _ -> throwE $ invalidParamsError "Returned CodeAction has no data field" + resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwE $ invalidParamsError "CodeAction has no data field" -- |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 @@ -59,11 +72,11 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = -- support. This means you don't have to check whether the client supports resolve -- and act accordingly in your own providers. mkCodeActionWithResolveAndCommand - :: forall ideState. + :: forall ideState a. (A.FromJSON a) => PluginId -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) - -> ([PluginCommand ideState], PluginHandlers ideState) + -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) + -> ([PluginCommand ideState], PluginHandlers ideState, PluginResolveHandlers ideState) mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = runExceptT $ do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params @@ -76,29 +89,51 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = pure $ InL ls -- If they do not we will drop the data field, in addition we will populate the command -- field with our command to execute the resolve, with the whole code action as it's argument. - | otherwise -> pure $ InL $ moveDataToCommand <$> ls - in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd plId codeResolveMethod)], - mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkPluginHandler SMethod_CodeActionResolve codeResolveMethod) - where moveDataToCommand :: Command |? CodeAction -> Command |? CodeAction - moveDataToCommand ca = - let dat = toJSON <$> ca ^? _R -- We need to take the whole codeAction + | otherwise -> pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls + in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd (codeResolveMethod))], + mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod, + mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) + where moveDataToCommand :: Uri -> Command |? CodeAction -> Command |? CodeAction + moveDataToCommand uri ca = + let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction -- And put it in the argument for the Command, that way we can later -- pas it to the resolve handler (which expects a whole code action) cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat) in ca & _R . L.data_ .~ Nothing -- Set the data field to nothing & _R . L.command ?~ cmd -- And set the command to our previously created command - executeResolveCmd :: PluginId -> PluginMethodHandler ideState Method_CodeActionResolve -> CommandFunction ideState CodeAction - executeResolveCmd pluginId resolveProvider ideState ca = do + wrapWithURI :: Uri -> CodeAction -> CodeAction + wrapWithURI uri codeAction = + codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) + where data_ = codeAction ^? L.data_ . _Just + executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction))-> CommandFunction ideState CodeAction + executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do withIndefiniteProgress "Executing code action..." Cancellable $ do - resolveResult <- resolveProvider ideState pluginId ca - case resolveResult of - Right CodeAction {_edit = Just wedits } -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right Data.Aeson.Null - Right _ -> pure $ Left $ responseError "No edit in CodeAction" - Left err -> pure $ Left err + case A.fromJSON value of + A.Error err -> pure $ Left $ parseError (Just value) (T.pack err) + A.Success (WithURI uri innerValue) -> do + case A.fromJSON innerValue of + A.Error err -> pure $ Left $ parseError (Just value) (T.pack err) + A.Success innerValueDecoded -> do + resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded + case resolveResult of + Right CodeAction {_edit = Just wedits } -> do + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) + pure $ Right A.Null + Right _ -> pure $ Left $ invalidParamsError "Returned CodeAction has no data field" + Left err -> pure $ Left err + executeResolveCmd _ _ CodeAction{_data_= value} = pure $ Left $ invalidParamsError ("CodeAction data field empty: " <> (T.pack $ show value)) + + +-- |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 WithURI = WithURI { + _uri :: Uri +, _value :: A.Value +} deriving (Generic, Show) +instance A.ToJSON WithURI +instance A.FromJSON WithURI supportsCodeActionResolve :: ClientCapabilities -> Bool supportsCodeActionResolve caps = @@ -106,3 +141,9 @@ supportsCodeActionResolve caps = && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of Just row -> "edit" `elem` row .! #properties _ -> False + +invalidParamsError :: T.Text -> ResponseError +invalidParamsError msg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: " <> msg) Nothing + +parseError :: Maybe A.Value -> T.Text -> ResponseError +parseError value errMsg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) Nothing diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 195b6b2c2b..ce4f793023 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -49,6 +49,11 @@ module Ide.Types , responseError , lookupCommandProvider , PluginResolveData(..) +, PluginResolveHandlers(..) +, PluginResolveHandler(..) +, ResolveFunction +, ResolveMethod(..) +, mkResolveHandler ) where @@ -61,7 +66,7 @@ import System.Posix.Signals #endif import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens (_Just, (.~), (?~), (^.), (^?)) +import Control.Lens (_Just, (.~), (^.), (^?)) import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) @@ -262,6 +267,7 @@ data PluginDescriptor (ideState :: *) = , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand ideState] , pluginHandlers :: PluginHandlers ideState + , pluginResolveHandlers:: PluginResolveHandlers ideState , pluginConfigDescriptor :: ConfigDescriptor , pluginNotificationHandlers :: PluginNotificationHandlers ideState , pluginModifyDynflags :: DynFlagsModifications @@ -405,11 +411,6 @@ instance PluginMethod Request Method_TextDocumentCodeAction where where uri = msgParams ^. L.textDocument . L.uri -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 _ = pluginResponsible uri pluginDesc @@ -444,11 +445,6 @@ 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) @@ -466,11 +462,6 @@ instance PluginMethod Request Method_TextDocumentDocumentSymbol where where uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request Method_CompletionItemResolve where - pluginEnabled _ msgParams pluginDesc config = - pluginResolverResponsible (msgParams ^. L.data_) pluginDesc - && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) - instance PluginMethod Request Method_TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) @@ -549,10 +540,6 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False -instance PluginRequestMethod Method_CodeActionResolve where - -- Resolve method should only ever get one response - combineResponses _ _ _ _ (x :| _) = x - instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x @@ -570,9 +557,6 @@ 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 @@ -614,10 +598,6 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc in [si] <> children' -instance PluginRequestMethod Method_CompletionItemResolve where - -- resolve method's should only ever get one response - combineResponses _ _ _ _ (x :| _) = x - instance PluginRequestMethod Method_TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where @@ -791,14 +771,6 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl f' SMethod_TextDocumentCompletion pid ide params@CompletionParams{_textDocument=TextDocumentIdentifier {_uri}} = pure . fmap (wrapCompletions pid _uri) <$> f ide pid params - -- If resolve handlers aren't declared with mkPluginHandler we won't need these here anymore - f' SMethod_CodeActionResolve pid ide params = - pure <$> f ide pid (unwrapResolveData params) - f' SMethod_CodeLensResolve pid ide params = - pure <$> f ide pid (unwrapResolveData params) - f' SMethod_CompletionItemResolve pid ide params = - pure <$> f ide pid (unwrapResolveData params) - -- This is the default case for all other methods f' _ pid ide params = pure <$> f ide pid params @@ -817,30 +789,6 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl InR $ InL $ cl & L.items .~ (wrapResolveData pid uri <$> _items) wrapCompletions _ _ (InR (InR r)) = InR $ InR r -wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a -wrapResolveData pid uri hasData = - hasData & L.data_ .~ (toJSON .PRD pid uri <$> data_) - where data_ = hasData ^? L.data_ . _Just - -unwrapResolveData :: L.HasData_ a (Maybe Value) => a -> a -unwrapResolveData hasData - | Just x <- hasData ^. L.data_ - , Success PRD {value = v} <- fromJSON x = hasData & L.data_ ?~ v --- If we can't successfully decode the value as a ORD type than --- we just return the type 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 PluginResolveData = PRD { - owner :: PluginId -, uri :: Uri -, value :: Value -} deriving (Generic, Show) -instance ToJSON PluginResolveData -instance FromJSON PluginResolveData - -- | Make a handler for plugins with no extra data mkPluginNotificationHandler :: PluginNotificationMethod m @@ -872,6 +820,7 @@ defaultPluginDescriptor plId = mempty mempty mempty + mempty defaultConfigDescriptor mempty mempty @@ -892,6 +841,7 @@ defaultCabalPluginDescriptor plId = mempty mempty mempty + mempty defaultConfigDescriptor mempty mempty @@ -918,17 +868,74 @@ type CommandFunction ideState a -- --------------------------------------------------------------------- +newtype PluginResolveHandlers ideState = PluginResolveHandlers (DMap ResolveMethod (PluginResolveHandler ideState)) +instance Semigroup (PluginResolveHandlers a) where + (PluginResolveHandlers a) <> (PluginResolveHandlers b) = PluginResolveHandlers $ DMap.union a b + +instance Monoid (PluginResolveHandlers a) where + mempty = PluginResolveHandlers mempty + +class (HasTracing (MessageParams m), L.HasData_ (MessageParams m) (Maybe Value)) => PluginResolveMethod (m :: Method ClientToServer Request) where +instance PluginResolveMethod Method_CodeActionResolve +instance PluginResolveMethod Method_CodeLensResolve +instance PluginResolveMethod Method_CompletionItemResolve +instance PluginResolveMethod Method_DocumentLinkResolve +instance PluginResolveMethod Method_InlayHintResolve +instance PluginResolveMethod Method_WorkspaceSymbolResolve + + +data ResolveMethod (m :: Method ClientToServer Request) = PluginResolveMethod m => ResolveMethod (SMethod m) +instance GEq ResolveMethod where + geq (ResolveMethod a) (ResolveMethod b) = geq a b +instance GCompare ResolveMethod where + gcompare (ResolveMethod a) (ResolveMethod b) = gcompare a b + -- Will something like this work? -type ResolveFunction ideState a m - = ideState +data PluginResolveHandler ideState (m :: Method ClientToServer Request) + = forall a. (FromJSON a) => ResolveHandler + (ideState + -> PluginId + -> MessageParams m + -> Uri + -> a + -> LspM Config (Either ResponseError (MessageResult m))) + +type ResolveFunction ideState a (m :: Method ClientToServer Request) = + ideState -> PluginId -> MessageParams m -> Uri -> a -> LspM Config (Either ResponseError (MessageResult m)) +-- | Make a handler for plugins with no extra data +mkResolveHandler + :: forall ideState a m. (FromJSON a, PluginResolveMethod m) + => SClientMethod m + -> (ideState + ->PluginId + -> MessageParams m + -> Uri + -> a + -> LspM Config (Either ResponseError (MessageResult m))) + -> PluginResolveHandlers ideState +mkResolveHandler m f = PluginResolveHandlers $ DMap.singleton (ResolveMethod m) (ResolveHandler f) +wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a +wrapResolveData pid uri hasData = + hasData & L.data_ .~ (toJSON .PluginResolveData pid uri <$> data_) + where data_ = hasData ^? L.data_ . _Just +-- |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 PluginResolveData = PluginResolveData { + resolvePlugin :: PluginId +, resolveURI :: Uri +, resolveValue :: Value +} deriving (Generic, Show) +instance ToJSON PluginResolveData +instance FromJSON PluginResolveData newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) deriving newtype (ToJSON, FromJSON, Hashable) @@ -1031,11 +1038,16 @@ instance HasTracing WorkspaceSymbolParams where traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams -instance HasTracing CompletionItem + +-- Instances for resolve types instance HasTracing CodeAction instance HasTracing CodeLens +instance HasTracing CompletionItem +instance HasTracing DocumentLink +instance HasTracing InlayHint +instance HasTracing WorkspaceSymbol -- --------------------------------------------------------------------- - +--Experimental resolve refactoring {-# NOINLINE pROCESS_ID #-} pROCESS_ID :: T.Text pROCESS_ID = unsafePerformIO getPid @@ -1068,11 +1080,3 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif - -pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool -pluginResolverResponsible (Just val) pluginDesc = - case fromJSON val of - (Success (PRD o _ _)) -> pluginId pluginDesc == o - _ -> False -- If we can't decode the data, something is seriously wrong --- If there is no data stored, than we can't resolve it -pluginResolverResponsible Nothing _ = False diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 4faefa7a24..1842e9bf95 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -117,6 +117,7 @@ import qualified Refact.Fixity as Refact import Ide.Plugin.Config hiding (Config) import Ide.Plugin.Properties +import Ide.Plugin.Resolve import Ide.PluginUtils import Ide.Types hiding (Config) @@ -188,11 +189,12 @@ fromStrictMaybe Strict.Nothing = Nothing descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - let (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) + let (pluginCommands, pluginHandlers, resolveHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) in (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = pluginCommands , pluginHandlers = pluginHandlers + , pluginResolveHandlers = resolveHandlers , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True , configCustomConfig = mkCustomConfig properties @@ -434,24 +436,20 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context diags = context ^. LSP.diagnostics -resolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeActionResolve -resolveProvider recorder ideState _pluginId ca@CodeAction {_data_ = Just data_} = pluginResponse $ do - case fromJSON data_ of - (Success (AA verTxtDocId@(VersionedTextDocumentIdentifier uri _))) -> do - file <- getNormalizedFilePath uri +resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve +resolveProvider recorder ideState _plId ca uri resolveValue = pluginResponse $ do + file <- getNormalizedFilePath uri + case resolveValue of + (AA verTxtDocId) -> do edit <- ExceptT $ liftIO $ applyHint recorder ideState file Nothing verTxtDocId pure $ ca & LSP.edit ?~ edit - (Success (AO verTxtDocId@(VersionedTextDocumentIdentifier uri _) pos hintTitle)) -> do + (AO verTxtDocId pos hintTitle) -> do let oneHint = OneHint pos hintTitle - file <- getNormalizedFilePath uri edit <- ExceptT $ liftIO $ applyHint recorder ideState file (Just oneHint) verTxtDocId pure $ ca & LSP.edit ?~ edit - (Success (IH verTxtDocId@(VersionedTextDocumentIdentifier uri _) hintTitle )) -> do - file <- getNormalizedFilePath uri + (IH verTxtDocId hintTitle ) -> do edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle pure $ ca & LSP.edit ?~ edit - Error s-> throwE ("JSON decoding error: " <> s) -resolveProvider _ _ _ _ = pluginResponse $ throwE "CodeAction with no data field" -- | Convert a hlint diagnostic into an apply and an ignore code action -- if applicable diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 7a743bcdd5..9aef0beb11 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -76,14 +76,15 @@ import Development.IDE.Types.Logger (Priority (..), import GHC.Generics (Generic) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, + ResolveFunction, defaultPluginDescriptor, - mkCodeActionHandlerWithResolve, mkPluginHandler) import Language.LSP.Protocol.Lens (HasChanges (changes)) import qualified Language.LSP.Protocol.Lens as L @@ -167,28 +168,26 @@ instance FromJSON ORDResolveData descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = - mkCodeActionHandlerWithResolve codeActionProvider resolveProvider +descriptor recorder plId = let (pluginHandler, resolveHandler) = mkCodeActionHandlerWithResolve codeActionProvider resolveProvider + in (defaultPluginDescriptor plId) + { pluginHandlers = pluginHandler + , pluginResolveHandlers = resolveHandler , pluginRules = collectRecSelsRule recorder } -resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve -resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) = - pluginResponse $ do - case fromJSON resData of - Success (ORDRD uri int) -> do - nfp <- getNormalizedFilePath uri - CRSR _ crsDetails exts <- collectRecSelResult ideState nfp - pragma <- getFirstPragma pId ideState nfp - case IntMap.lookup int crsDetails of - Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} - -- We need to throw a content modified error here, see - -- https://github.com/microsoft/language-server-protocol/issues/1738 - -- but we need fendor's plugin error response pr to make it - -- convenient to use here, so we will wait to do that till that's merged - _ -> throwE "Content Modified Error" - _ -> throwE "Unable to deserialize the data" +resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve +resolveProvider ideState plId ca uri (ORDRD _ int) = + pluginResponse $ do + nfp <- getNormalizedFilePath uri + CRSR _ crsDetails exts <- collectRecSelResult ideState nfp + pragma <- getFirstPragma plId ideState nfp + case IntMap.lookup int crsDetails of + Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} + -- We need to throw a content modified error here, see + -- https://github.com/microsoft/language-server-protocol/issues/1738 + -- but we need fendor's plugin error response pr to make it + -- convenient to use here, so we will wait to do that till that's merged + _ -> throwE "Content Modified Error" codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = From 7954c724331ebc8db7b013a12620867045caee85 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 8 Jul 2023 17:31:16 +0300 Subject: [PATCH 03/14] Flag and test fixes --- ghcide/test/exe/Main.hs | 13 ++++++++----- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 10 +++++----- test/functional/Completion.hs | 12 ++++++++---- 3 files changed, 21 insertions(+), 14 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 1b825e9d0d..208871a933 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1571,7 +1571,7 @@ completionTest name src pos expected = testSessionWait name $ do [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do CompletionItem{..} <- - if expectedSig || expectedDocs + if (expectedSig || expectedDocs) && isJust (item ^. L.data_) then do rsp <- request SMethod_CompletionItemResolve item case rsp ^. L.result of @@ -2081,10 +2081,13 @@ completionDocTests = _ <- waitForDiagnostics compls <- getCompletions doc pos rcompls <- forM compls $ \item -> do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x + if isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item let compls' = [ -- We ignore doc uris since it points to the local path which determined by specific machines case mn of diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 7d2fe74d4b..4eae148d2f 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -5,7 +5,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve, +module Ide.Plugin.Resolve +(mkCodeActionHandlerWithResolve, mkCodeActionWithResolveAndCommand) where import Control.Lens (_Just, (&), (.~), (?~), (^.), @@ -27,7 +28,7 @@ import Language.LSP.Server (LspM, LspT, sendRequest, withIndefiniteProgress) - -- |When provided with both a codeAction provider and an affiliated codeAction +-- |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 @@ -125,9 +126,8 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = executeResolveCmd _ _ CodeAction{_data_= value} = pure $ Left $ invalidParamsError ("CodeAction data field empty: " <> (T.pack $ show value)) --- |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 +-- |To execute the resolve provider as a command, we need to additionally store +-- the URI that was provided to the original code action. data WithURI = WithURI { _uri :: Uri , _value :: A.Value diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 08280d4c4f..f5132a1b62 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -7,6 +7,7 @@ import Control.Lens hiding ((.=)) import Control.Monad import Data.Aeson (object, (.=)) import Data.Foldable (find) +import Data.Maybe (isJust) import Data.Row.Records (focus) import qualified Data.Text as T import Ide.Plugin.Config (maxCompletions) @@ -18,10 +19,13 @@ getResolvedCompletions :: TextDocumentIdentifier -> Position -> Session [Complet getResolvedCompletions doc pos = do xs <- getCompletions doc pos forM xs $ \item -> do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x + if isJust (item ^. detail) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item tests :: TestTree tests = testGroup "completions" [ From 2995b506b68f2b0fe625b6dba78208afc3791d3b Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 8 Jul 2023 18:05:29 +0300 Subject: [PATCH 04/14] Fix typo --- test/functional/Completion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index f5132a1b62..0511e75fcc 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -19,7 +19,7 @@ getResolvedCompletions :: TextDocumentIdentifier -> Position -> Session [Complet getResolvedCompletions doc pos = do xs <- getCompletions doc pos forM xs $ \item -> do - if isJust (item ^. detail) + if isJust (item ^. data_) then do rsp <- request SMethod_CompletionItemResolve item case rsp ^. result of From 84e0f3cb43f405f2f197e29b416e08f841cb0e90 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 11 Jul 2023 18:51:49 +0300 Subject: [PATCH 05/14] Dump most of the special resolve logic --- .../src/Development/IDE/Plugin/Completions.hs | 2 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 64 ------------- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 12 +-- hls-plugin-api/src/Ide/Types.hs | 89 ++++++++++--------- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 3 +- .../src/Ide/Plugin/OverloadedRecordDot.hs | 3 +- 6 files changed, 56 insertions(+), 117 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 9bcf77a2fb..4f6b8cfa97 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -66,7 +66,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP - , pluginResolveHandlers = mkResolveHandler SMethod_CompletionItemResolve resolveCompletion + <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index ad8054cad3..c134a26045 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -54,16 +54,12 @@ data Log = LogPluginError PluginId ResponseError | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier - | LogNoResolveData - | LogParseError String (Maybe A.Value) instance Pretty Log where pretty = \case LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" - LogNoResolveData -> "No resolve data in resolve request" - LogParseError msg value -> "Error while parsing: " <> pretty msg <> ", value = " <> viaShow value instance Show Log where show = renderString . layoutCompact . pretty @@ -103,19 +99,11 @@ logAndReturnError recorder p errCode msg = do logWith recorder Warning $ LogPluginError p err pure $ Left err --- | Build a ResponseError and log it before returning to the caller -logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a) -logAndReturnError' recorder errCode msg = do - let err = ResponseError errCode (T.pack $ show msg) Nothing - logWith recorder Warning $ msg - pure $ Left err - -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <> - mkPlugin (extensibleResolvePlugins recorder) id <> mkPlugin (extensiblePlugins recorder) id <> mkPlugin (extensibleNotificationPlugins recorder) id <> mkPluginFromDescriptor dynFlagsPlugins HLS.pluginModifyDynflags @@ -213,46 +201,6 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- --------------------------------------------------------------------- -extensibleResolvePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config -extensibleResolvePlugins recorder xs = mempty { P.pluginHandlers = handlers } - where - IdeResolveHandlers handlers' = foldMap bakePluginId xs - bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeResolveHandlers - bakePluginId (pid,pluginDesc) = IdeResolveHandlers $ DMap.map - (\f -> IdeResolveHandler [(pid,pluginDesc,f)]) - hs - where - PluginResolveHandlers hs = HLS.pluginResolveHandlers pluginDesc - handlers = mconcat $ do - (ResolveMethod m :=> IdeResolveHandler fs') <- DMap.assocs handlers' - pure $ requestHandler m $ \ide params -> do - case A.fromJSON <$> (params ^. L.data_) of - (Just (A.Success (HLS.PluginResolveData owner uri value) )) -> do - -- Only run plugins that are allowed to run on this request - let fs = filter (\(pid,_ , _) -> pid == owner) fs' - -- Clients generally don't display ResponseErrors so instead we log any that we come across - case nonEmpty fs of - Nothing -> do - logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing - msg = pluginNotEnabled m fs' - return $ Left err - Just ((pid, _, ResolveHandler handler) NE.:| _) -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - case A.fromJSON value of - A.Success decodedValue -> do - otTracedProvider pid (fromString $ show m) $ do - handler ide pid params uri decodedValue - `catchAny` (\e -> pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg e pid) Nothing) - A.Error err -> do - logAndReturnError' recorder (InR ErrorCodes_ParseError) (LogParseError err (Just value)) - - Nothing -> do - logAndReturnError' recorder (InR ErrorCodes_InvalidParams) LogNoResolveData - (Just (A.Error str)) -> do - logAndReturnError' recorder (InR ErrorCodes_ParseError) (LogParseError str (params ^. L.data_)) --- --------------------------------------------------------------------- - extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } where @@ -338,10 +286,6 @@ combineErrors xs = ResponseError (InR ErrorCodes_InternalError) (T.pack (show x newtype IdeHandler (m :: Method ClientToServer Request) = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (MessageResult m))))] -newtype IdeResolveHandler (m :: Method ClientToServer Request) - = IdeResolveHandler [(PluginId, PluginDescriptor IdeState, PluginResolveHandler IdeState m)] - - -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: Method ClientToServer Notification) = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] @@ -349,7 +293,6 @@ newtype IdeNotificationHandler (m :: Method ClientToServer Notification) -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) -newtype IdeResolveHandlers = IdeResolveHandlers (DMap ResolveMethod IdeResolveHandler) newtype IdeNotificationHandlers = IdeNotificationHandlers (DMap IdeNotification IdeNotificationHandler) instance Semigroup IdeHandlers where @@ -359,13 +302,6 @@ instance Semigroup IdeHandlers where instance Monoid IdeHandlers where mempty = IdeHandlers mempty -instance Semigroup IdeResolveHandlers where - (IdeResolveHandlers a) <> (IdeResolveHandlers b) = IdeResolveHandlers $ DMap.unionWithKey go a b - where - go _ (IdeResolveHandler a) (IdeResolveHandler b) = IdeResolveHandler (a <> b) -instance Monoid IdeResolveHandlers where - mempty = IdeResolveHandlers mempty - instance Semigroup IdeNotificationHandlers where (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b where diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 4eae148d2f..e692e33008 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -37,7 +37,7 @@ mkCodeActionHandlerWithResolve :: forall ideState a. (A.FromJSON a) => (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) - -> (PluginHandlers ideState, PluginResolveHandlers ideState) + -> PluginHandlers ideState mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = runExceptT $ do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params @@ -50,7 +50,7 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = --This is the actual part where we call resolveCodeAction which fills in the edit data for the client | otherwise -> InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - , mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) + <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing @@ -77,7 +77,7 @@ mkCodeActionWithResolveAndCommand PluginId -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) - -> ([PluginCommand ideState], PluginHandlers ideState, PluginResolveHandlers ideState) + -> ([PluginCommand ideState], PluginHandlers ideState) mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = let newCodeActionMethod ideState pid params = runExceptT $ do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params @@ -91,9 +91,9 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = -- If they do not we will drop the data field, in addition we will populate the command -- field with our command to execute the resolve, with the whole code action as it's argument. | otherwise -> pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls - in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd (codeResolveMethod))], - mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod, - mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) + in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)], + mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where moveDataToCommand :: Uri -> Command |? CodeAction -> Command |? CodeAction moveDataToCommand uri ca = let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ce4f793023..8ef05dc690 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -48,11 +48,7 @@ module Ide.Types , installSigUsr1Handler , responseError , lookupCommandProvider -, PluginResolveData(..) -, PluginResolveHandlers(..) -, PluginResolveHandler(..) , ResolveFunction -, ResolveMethod(..) , mkResolveHandler ) where @@ -267,7 +263,6 @@ data PluginDescriptor (ideState :: *) = , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand ideState] , pluginHandlers :: PluginHandlers ideState - , pluginResolveHandlers:: PluginResolveHandlers ideState , pluginConfigDescriptor :: ConfigDescriptor , pluginNotificationHandlers :: PluginNotificationHandlers ideState , pluginModifyDynflags :: DynFlagsModifications @@ -411,6 +406,11 @@ instance PluginMethod Request Method_TextDocumentCodeAction where where uri = msgParams ^. L.textDocument . L.uri +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 _ = pluginResponsible uri pluginDesc @@ -445,6 +445,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) @@ -462,6 +467,10 @@ instance PluginMethod Request Method_TextDocumentDocumentSymbol where where uri = msgParams ^. L.textDocument . L.uri +instance PluginMethod Request Method_CompletionItemResolve where + pluginEnabled _ msgParams pluginDesc config = pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) + instance PluginMethod Request Method_TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) @@ -540,6 +549,10 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False +instance PluginRequestMethod Method_CodeActionResolve where + -- Resolve methods should only have one response + combineResponses _ _ _ _ (x :| _) = x + instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x @@ -557,6 +570,9 @@ 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 @@ -598,6 +614,10 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc in [si] <> children' +instance PluginRequestMethod Method_CompletionItemResolve where + -- resolve methods should only have one response + combineResponses _ _ _ _ (x :| _) = x + instance PluginRequestMethod Method_TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where @@ -820,7 +840,6 @@ defaultPluginDescriptor plId = mempty mempty mempty - mempty defaultConfigDescriptor mempty mempty @@ -841,7 +860,6 @@ defaultCabalPluginDescriptor plId = mempty mempty mempty - mempty defaultConfigDescriptor mempty mempty @@ -868,38 +886,6 @@ type CommandFunction ideState a -- --------------------------------------------------------------------- -newtype PluginResolveHandlers ideState = PluginResolveHandlers (DMap ResolveMethod (PluginResolveHandler ideState)) -instance Semigroup (PluginResolveHandlers a) where - (PluginResolveHandlers a) <> (PluginResolveHandlers b) = PluginResolveHandlers $ DMap.union a b - -instance Monoid (PluginResolveHandlers a) where - mempty = PluginResolveHandlers mempty - -class (HasTracing (MessageParams m), L.HasData_ (MessageParams m) (Maybe Value)) => PluginResolveMethod (m :: Method ClientToServer Request) where -instance PluginResolveMethod Method_CodeActionResolve -instance PluginResolveMethod Method_CodeLensResolve -instance PluginResolveMethod Method_CompletionItemResolve -instance PluginResolveMethod Method_DocumentLinkResolve -instance PluginResolveMethod Method_InlayHintResolve -instance PluginResolveMethod Method_WorkspaceSymbolResolve - - -data ResolveMethod (m :: Method ClientToServer Request) = PluginResolveMethod m => ResolveMethod (SMethod m) -instance GEq ResolveMethod where - geq (ResolveMethod a) (ResolveMethod b) = geq a b -instance GCompare ResolveMethod where - gcompare (ResolveMethod a) (ResolveMethod b) = gcompare a b - --- Will something like this work? -data PluginResolveHandler ideState (m :: Method ClientToServer Request) - = forall a. (FromJSON a) => ResolveHandler - (ideState - -> PluginId - -> MessageParams m - -> Uri - -> a - -> LspM Config (Either ResponseError (MessageResult m))) - type ResolveFunction ideState a (m :: Method ClientToServer Request) = ideState -> PluginId @@ -910,7 +896,7 @@ type ResolveFunction ideState a (m :: Method ClientToServer Request) = -- | Make a handler for plugins with no extra data mkResolveHandler - :: forall ideState a m. (FromJSON a, PluginResolveMethod m) + :: forall ideState a m. (FromJSON a, PluginRequestMethod m, L.HasData_ (MessageParams m) (Maybe Value)) => SClientMethod m -> (ideState ->PluginId @@ -918,8 +904,22 @@ mkResolveHandler -> Uri -> a -> LspM Config (Either ResponseError (MessageResult m))) - -> PluginResolveHandlers ideState -mkResolveHandler m f = PluginResolveHandlers $ DMap.singleton (ResolveMethod m) (ResolveHandler f) + -> PluginHandlers ideState +mkResolveHandler m f = mkPluginHandler m f' + where f' ideState plId params = do + case fromJSON <$> (params ^. L.data_) of + (Just (Success (PluginResolveData owner uri value) )) -> do + if owner == plId + then + case fromJSON value of + Success decodedValue -> do + f ideState plId params uri decodedValue + Error err -> do + pure $ Left $ ResponseError (InR ErrorCodes_ParseError) (parseError value err) Nothing + else pure $ Left $ ResponseError (InR ErrorCodes_InvalidRequest) invalidRequest Nothing + _ -> pure $ Left $ ResponseError (InR ErrorCodes_InvalidRequest) invalidRequest Nothing + invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!" + parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err) wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a wrapResolveData pid uri hasData = @@ -1080,3 +1080,8 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif +pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool +pluginResolverResponsible (Just (fromJSON -> (Success (PluginResolveData o _ _)))) pluginDesc = + pluginId pluginDesc == o +-- We want to fail closed +pluginResolverResponsible _ _ = False diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 1842e9bf95..4a5099b842 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -189,12 +189,11 @@ fromStrictMaybe Strict.Nothing = Nothing descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - let (pluginCommands, pluginHandlers, resolveHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) + let (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) in (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = pluginCommands , pluginHandlers = pluginHandlers - , pluginResolveHandlers = resolveHandlers , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True , configCustomConfig = mkCustomConfig properties diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 9aef0beb11..174358e79e 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -168,10 +168,9 @@ instance FromJSON ORDResolveData descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = let (pluginHandler, resolveHandler) = mkCodeActionHandlerWithResolve codeActionProvider resolveProvider +descriptor recorder plId = let pluginHandler = mkCodeActionHandlerWithResolve codeActionProvider resolveProvider in (defaultPluginDescriptor plId) { pluginHandlers = pluginHandler - , pluginResolveHandlers = resolveHandler , pluginRules = collectRecSelsRule recorder } From 1587dd70bd6cd37b63c131c8937c33b93b1d16f6 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 12 Jul 2023 13:21:49 +0300 Subject: [PATCH 06/14] Incorporate changes from hlint-suggestions branch --- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 62 +++++++++++++++++++----- 1 file changed, 50 insertions(+), 12 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index e692e33008..4fa602568f 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -15,6 +15,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) import qualified Data.Aeson as A +import Data.Maybe (catMaybes) import Data.Row ((.!)) import qualified Data.Text as T import GHC.Generics (Generic) @@ -67,11 +68,13 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = _ -> throwE $ invalidParamsError "Returned CodeAction has no data field" resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwE $ invalidParamsError "CodeAction has no data field" --- |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. +-- |When provided with both a codeAction provider with a data field and a resolve +-- provider, this function creates a handler that creates a command that uses +-- your resolve 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. see Note [Code action resolve fallback to commands] +-- Also: This helper only works with workspace edits, not commands. Any command set +-- either in the original code action or in the resolve will be ignored. mkCodeActionWithResolveAndCommand :: forall ideState a. (A.FromJSON a) => PluginId @@ -98,7 +101,9 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = moveDataToCommand uri ca = let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction -- And put it in the argument for the Command, that way we can later - -- pas it to the resolve handler (which expects a whole code action) + -- pass it to the resolve handler (which expects a whole code action) + -- It should be noted that mkLspCommand already specifies the command + -- to the plugin, so we don't need to do that here. cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat) in ca & _R . L.data_ .~ Nothing -- Set the data field to nothing @@ -109,7 +114,7 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = where data_ = codeAction ^? L.data_ . _Just executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction))-> CommandFunction ideState CodeAction executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do - withIndefiniteProgress "Executing code action..." Cancellable $ do + withIndefiniteProgress "Applying edits for code action..." Cancellable $ do case A.fromJSON value of A.Error err -> pure $ Left $ parseError (Just value) (T.pack err) A.Success (WithURI uri innerValue) -> do @@ -118,14 +123,33 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = A.Success innerValueDecoded -> do resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded case resolveResult of - Right CodeAction {_edit = Just wedits } -> do + Right ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) pure $ Right A.Null - Right _ -> pure $ Left $ invalidParamsError "Returned CodeAction has no data field" + Right ca2@CodeAction {_edit = Just _ } -> + pure $ Left $ + internalError $ + "The resolve provider unexpectedly returned a code action with the following differing fields: " + <> (T.pack $ show $ diffCodeActions ca ca2) + Right _ -> pure $ Left $ internalError "The resolve provider unexpectedly returned a result with no data field" Left err -> pure $ Left err - executeResolveCmd _ _ CodeAction{_data_= value} = pure $ Left $ invalidParamsError ("CodeAction data field empty: " <> (T.pack $ show value)) + executeResolveCmd _ _ CodeAction{_data_= value} = pure $ Left $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) +-- TODO: Remove once provided by lsp-types +-- |Compares two CodeActions and returns a list of fields that are not equal +diffCodeActions :: CodeAction -> CodeAction -> [T.Text] +diffCodeActions ca ca2 = + let titleDiff = if ca ^. L.title == ca2 ^. L.title then Nothing else Just "title" + kindDiff = if ca ^. L.kind == ca2 ^. L.kind then Nothing else Just "kind" + diagnosticsDiff = if ca ^. L.diagnostics == ca2 ^. L.diagnostics then Nothing else Just "diagnostics" + commandDiff = if ca ^. L.command == ca2 ^. L.command then Nothing else Just "diagnostics" + isPreferredDiff = if ca ^. L.isPreferred == ca2 ^. L.isPreferred then Nothing else Just "isPreferred" + dataDiff = if ca ^. L.data_ == ca2 ^. L.data_ then Nothing else Just "data" + disabledDiff = if ca ^. L.disabled == ca2 ^. L.disabled then Nothing else Just "disabled" + editDiff = if ca ^. L.edit == ca2 ^. L.edit then Nothing else Just "edit" + in catMaybes [titleDiff, kindDiff, diagnosticsDiff, commandDiff, isPreferredDiff, dataDiff, disabledDiff, editDiff] + -- |To execute the resolve provider as a command, we need to additionally store -- the URI that was provided to the original code action. data WithURI = WithURI { @@ -142,8 +166,22 @@ supportsCodeActionResolve caps = Just row -> "edit" `elem` row .! #properties _ -> False +internalError :: T.Text -> ResponseError +internalError msg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: Internal Error : " <> msg) Nothing + invalidParamsError :: T.Text -> ResponseError -invalidParamsError msg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: " <> msg) Nothing +invalidParamsError msg = ResponseError (InR ErrorCodes_InvalidParams) ("Ide.Plugin.Resolve: : " <> msg) Nothing parseError :: Maybe A.Value -> T.Text -> ResponseError -parseError value errMsg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) Nothing +parseError value errMsg = ResponseError (InR ErrorCodes_ParseError) ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) Nothing + +{- Note [Code action resolve fallback to commands] + To make supporting code action resolve easy for plugins, we want to let them + provide one implementation that can be used both when clients support + resolve, and when they don't. + The way we do this is to have them always implement a resolve handler. + Then, if the client doesn't support resolve, we instead install the resolve + handler as a _command_ handler, passing the code action literal itself + as the command argument. This allows the command handler to have + the same interface as the resolve handler! + -} From 5291541222431a66ba8a384749b6ad14208bf020 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 12 Jul 2023 13:24:08 +0300 Subject: [PATCH 07/14] updates due to merge --- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 4fa602568f..b9111c6a87 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -125,7 +125,7 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = case resolveResult of Right ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right A.Null + pure $ Right $ InR Null Right ca2@CodeAction {_edit = Just _ } -> pure $ Left $ internalError $ From 1405a0c588861c38d42b5f400b2b6cd35cbd13bb Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 12 Jul 2023 13:58:18 +0300 Subject: [PATCH 08/14] Convert ExplicitImport to use ResolveFunction --- .../src/Ide/Plugin/ExplicitImports.hs | 28 ++++++------------- 1 file changed, 9 insertions(+), 19 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 c99ff2ee1d..eff8a242a1 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -6,7 +6,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -25,9 +24,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Maybe -import qualified Data.Aeson as A (Result (..), - ToJSON (toJSON), - fromJSON) +import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) import qualified Data.IntMap as IM (IntMap, elems, fromList, (!?)) @@ -47,6 +44,7 @@ import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Plugin.RangeMap (filterByRange) import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import Ide.Plugin.Resolve import Ide.PluginUtils (getNormalizedFilePath, handleMaybe, handleMaybeM, @@ -92,7 +90,7 @@ descriptorForModules recorder modFilter plId = pluginHandlers = -- This plugin provides code lenses mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) - <> mkPluginHandler SMethod_CodeLensResolve (lensResolveProvider recorder) + <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) -- This plugin provides code actions <> mkCodeActionHandlerWithResolve (codeActionProvider recorder) (codeActionResolveProvider recorder) @@ -139,8 +137,8 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { , _range = range , _command = Nothing } -lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeLensResolve -lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSON -> A.Success (ResolveOne uri uid))}) +lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeLensResolve +lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = data_}) uri (ResolveOne _ uid) = pluginResponse $ do nfp <- getNormalizedFilePath uri (MinimalImportsResult{forResolve}) <- @@ -153,14 +151,10 @@ lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSO where mkCommand :: PluginId -> TextEdit -> Command mkCommand pId TextEdit{_newText} = let title = abbreviateImportTitle _newText - _arguments = Just [data_] + _arguments = pure <$> data_ in mkLspCommand pId importCommandId title _arguments -lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON -> A.Success (ResolveAll _))}) = do +lensResolveProvider _ _ _ _ _ (ResolveAll _) = do 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_ = 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 @@ -191,15 +185,11 @@ codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier , _disabled = Nothing , _data_ = data_} -codeActionResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeActionResolve -codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON -> A.Success rd)}) = +codeActionResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeActionResolve +codeActionResolveProvider _ ideState _ ca _ rd = pluginResponse $ do 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_ = 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 From aa3f2819c970b06f72dce5970a29a74cb71ef2f3 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 12 Jul 2023 16:07:51 +0300 Subject: [PATCH 09/14] Fix flags and test issues --- hls-plugin-api/src/Ide/Types.hs | 9 +++++---- .../src/Ide/Plugin/ExplicitImports.hs | 5 ++--- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 -- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 7ea396380a..0ce64f4623 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -62,7 +62,7 @@ import System.Posix.Signals #endif import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens (_Just, (.~), (^.), (^?)) +import Control.Lens (_Just, (.~), (?~), (^.), (^?)) import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) @@ -912,9 +912,10 @@ mkResolveHandler m f = mkPluginHandler m f' if owner == plId then case fromJSON value of - Success decodedValue -> do - f ideState plId params uri decodedValue - Error err -> do + Success decodedValue -> + let newParams = params & L.data_ ?~ value + in f ideState plId newParams uri decodedValue + Error err -> pure $ Left $ ResponseError (InR ErrorCodes_ParseError) (parseError value err) Nothing else pure $ Left $ ResponseError (InR ErrorCodes_InvalidRequest) invalidRequest Nothing _ -> pure $ Left $ ResponseError (InR ErrorCodes_InvalidRequest) invalidRequest Nothing 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 eff8a242a1..5a3e47bf5e 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -138,7 +138,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier { , _command = Nothing } lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeLensResolve -lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = data_}) uri (ResolveOne _ uid) +lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = pluginResponse $ do nfp <- getNormalizedFilePath uri (MinimalImportsResult{forResolve}) <- @@ -151,8 +151,7 @@ lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = data_}) uri (ResolveO where mkCommand :: PluginId -> TextEdit -> Command mkCommand pId TextEdit{_newText} = let title = abbreviateImportTitle _newText - _arguments = pure <$> data_ - in mkLspCommand pId importCommandId title _arguments + in mkLspCommand pId importCommandId title (Just $ [A.toJSON rd]) lensResolveProvider _ _ _ _ _ (ResolveAll _) = do pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: ResolveAll" Nothing diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 4a5099b842..75e1cd0ebd 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -144,8 +144,6 @@ import GHC.Generics (Generic) import System.Environment (setEnv, unsetEnv) #endif -import Data.Aeson (Result (Error, Success), - fromJSON) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- From 339e4f9d859cca2defc61e61665ec421913fc885 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 12 Jul 2023 14:14:21 +0000 Subject: [PATCH 10/14] move logger to hls-plugin-api --- exe/Main.hs | 4 +-- exe/Wrapper.hs | 4 +-- ghcide/exe/Main.hs | 8 ++--- ghcide/ghcide.cabal | 1 - .../session-loader/Development/IDE/Session.hs | 14 ++++----- ghcide/src/Development/IDE.hs | 2 +- ghcide/src/Development/IDE/Core/FileExists.hs | 6 ++-- ghcide/src/Development/IDE/Core/FileStore.hs | 4 +-- ghcide/src/Development/IDE/Core/OfInterest.hs | 6 ++-- ghcide/src/Development/IDE/Core/Rules.hs | 4 +-- ghcide/src/Development/IDE/Core/Service.hs | 4 +-- ghcide/src/Development/IDE/Core/Shake.hs | 4 +-- ghcide/src/Development/IDE/Core/Tracing.hs | 2 +- .../Development/IDE/LSP/HoverDefinition.hs | 2 +- .../src/Development/IDE/LSP/LanguageServer.hs | 4 +-- .../src/Development/IDE/LSP/Notifications.hs | 2 +- ghcide/src/Development/IDE/Main.hs | 2 +- ghcide/src/Development/IDE/Main/HeapStats.hs | 8 ++--- ghcide/src/Development/IDE/Monitoring/EKG.hs | 4 +-- .../src/Development/IDE/Plugin/Completions.hs | 2 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 2 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 4 +-- ghcide/src/Development/IDE/Types/Action.hs | 12 +++---- ghcide/test/exe/HieDbRetry.hs | 31 +++++++++---------- ghcide/test/exe/Main.hs | 2 +- hls-plugin-api/hls-plugin-api.cabal | 6 ++++ .../src/Ide}/Logger.hs | 14 ++++++--- hls-test-utils/src/Test/Hls.hs | 10 +++--- .../src/Ide/Plugin/AlternateNumberFormat.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 2 +- plugins/hls-code-range-plugin/test/Main.hs | 2 +- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 2 +- .../src/Ide/Plugin/Eval/Rules.hs | 2 +- .../src/Ide/Plugin/ExplicitFields.hs | 4 +-- .../src/Ide/Plugin/ModuleName.hs | 2 +- .../src/Ide/Plugin/OverloadedRecordDot.hs | 4 +-- .../test/Main.hs | 2 +- .../src/Development/IDE/GHC/ExactPrint.hs | 2 +- .../src/Development/IDE/Plugin/CodeAction.hs | 4 +-- .../src/Ide/Plugin/RefineImports.hs | 2 +- .../new/src/Wingman/LanguageServer.hs | 2 +- .../new/src/Wingman/Plugin.hs | 2 +- .../old/src/Wingman/LanguageServer.hs | 2 +- .../old/src/Wingman/Plugin.hs | 2 +- src/HlsPlugins.hs | 2 +- src/Ide/Arguments.hs | 2 +- src/Ide/Main.hs | 4 +-- 47 files changed, 112 insertions(+), 102 deletions(-) rename {ghcide/src/Development/IDE/Types => hls-plugin-api/src/Ide}/Logger.hs (97%) diff --git a/exe/Main.hs b/exe/Main.hs index ee46a7cbcf..16f99a44e0 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -13,7 +13,7 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Maybe (catMaybes) import Data.Text (Text) -import Development.IDE.Types.Logger (Doc, Priority (Error, Info), +import Ide.Logger (Doc, Priority (Error, Info), Recorder, WithPriority (WithPriority, priority), cfilter, cmapWithPrio, @@ -21,7 +21,7 @@ import Development.IDE.Types.Logger (Doc, Priority (Error, Info), layoutPretty, logWith, makeDefaultStderrRecorder, renderStrict, withFileRecorder) -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import qualified HlsPlugins as Plugins import Ide.Arguments (Arguments (..), GhcideArguments (..), diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6bebc98923..32f7327e56 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -45,14 +45,14 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Development.IDE.LSP.LanguageServer (runLanguageServer) import qualified Development.IDE.Main as Main -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import GHC.Stack.Types (emptyCallStack) +import Ide.Logger (Doc, Logger (Logger), Pretty (pretty), Recorder (logger_), WithPriority (WithPriority), cmapWithPrio, makeDefaultStderrRecorder, toCologActionWithPrio) -import GHC.Stack.Types (emptyCallStack) import Ide.Plugin.Config (Config) import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Protocol.Message (Method (Method_Initialize), diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index ec72d277b6..0c6b1dd0f9 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -22,7 +22,9 @@ import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Options +import GHC.Stack (emptyCallStack) +import Ide.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Error, Info), @@ -33,9 +35,7 @@ import Development.IDE.Types.Logger (Logger (Logger), layoutPretty, makeDefaultStderrRecorder, renderStrict) -import qualified Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Options -import GHC.Stack (emptyCallStack) +import qualified Ide.Logger as Logger import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (PluginDescriptor (pluginNotificationHandlers), diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 9ba17e756a..8fbd855be2 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -197,7 +197,6 @@ library Development.IDE.Types.HscEnvEq Development.IDE.Types.KnownTargets Development.IDE.Types.Location - Development.IDE.Types.Logger Development.IDE.Types.Monitoring Development.IDE.Monitoring.OpenTelemetry Development.IDE.Types.Options diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cfc9796c33..afcac00308 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -65,13 +65,6 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Priority (Debug, Error, Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - nest, - toCologActionWithPrio, - vcat, viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -79,6 +72,13 @@ import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios import Hie.Implicit.Cradle (loadImplicitHieCradle) +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + nest, + toCologActionWithPrio, + vcat, viaShow, (<+>)) import Language.LSP.Protocol.Message import Language.LSP.Server import System.Directory diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 503f0104f8..8aa3b8c815 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -55,4 +55,4 @@ import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..), hscEnv, hscEnvWithImportPaths) import Development.IDE.Types.Location as X -import Development.IDE.Types.Logger as X +import Ide.Logger as X diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 9a1caecd88..b7e568d0d6 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -27,11 +27,11 @@ import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Recorder, WithPriority, - cmapWithPrio) import Development.IDE.Types.Options import qualified Focus +import Ide.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Config (Config) import Language.LSP.Protocol.Types import Language.LSP.Server hiding (getVirtualFile) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 89d50432cf..229aaecb96 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -54,7 +54,7 @@ import qualified System.Directory as Dir #else #endif -import qualified Development.IDE.Types.Logger as L +import qualified Ide.Logger as L import Data.Aeson (ToJSON (toJSON)) import qualified Data.Binary as B @@ -63,7 +63,7 @@ import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Priority (Info), Recorder, WithPriority, diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index ddb919a424..17858544c2 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -40,13 +40,13 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Development.IDE.Types.Options (IdeTesting (..)) +import GHC.TypeLits (KnownSymbol) +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio, logDebug) -import Development.IDE.Types.Options (IdeTesting (..)) -import GHC.TypeLits (KnownSymbol) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 109259df7b..10a7b9c362 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -153,9 +153,9 @@ import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) +import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 3e61ee582e..e88dd341ab 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -23,13 +23,13 @@ import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, +import Development.IDE.Types.Options (IdeOptions (..)) +import Ide.Logger as Logger (Logger, Pretty (pretty), Priority (Debug), Recorder, WithPriority, cmapWithPrio) -import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4ba1090087..b66d499562 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -152,8 +152,8 @@ import Development.IDE.Types.Exports import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding (Priority) -import qualified Development.IDE.Types.Logger as Logger +import Ide.Logger hiding (Priority) +import qualified Ide.Logger as Logger import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Options import Development.IDE.Types.Shake diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index ce4e3b6bc3..ee87c18727 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -29,7 +29,7 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger)) +import Ide.Logger (Logger (Logger)) import Ide.Types (PluginId (..)) import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index fdd51a9014..7ad2021dc2 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -21,7 +21,7 @@ import Development.IDE.Core.Actions import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Ide.Logger import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5e3a8800b7..80d7d1b7bf 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -41,9 +41,9 @@ import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log, Priority) import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger -import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) +import Ide.Logger +import qualified Ide.Logger as Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 80b956904d..6674bd4b86 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -37,8 +37,8 @@ import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log, Priority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) +import Ide.Logger import Ide.Types import Numeric.Natural diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a7b124a96a..b440b4c2ff 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -77,7 +77,7 @@ import Development.IDE.Session (SessionLoadingOptions import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, +import Ide.Logger (Logger, Pretty (pretty), Priority (Info, Warning), Recorder, diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index a1c0b9f3d7..ac1af8f28e 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -6,11 +6,11 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Data.Word -import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), - Recorder, WithPriority, hsep, - logWith, (<+>)) import GHC.Stats -import Text.Printf (printf) +import Ide.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) +import Text.Printf (printf) data Log = LogHeapStatsPeriod !Int diff --git a/ghcide/src/Development/IDE/Monitoring/EKG.hs b/ghcide/src/Development/IDE/Monitoring/EKG.hs index 2999285442..e4d9f6d0ae 100644 --- a/ghcide/src/Development/IDE/Monitoring/EKG.hs +++ b/ghcide/src/Development/IDE/Monitoring/EKG.hs @@ -1,14 +1,14 @@ {-# LANGUAGE CPP #-} module Development.IDE.Monitoring.EKG(monitoring) where -import Development.IDE.Types.Logger (Logger) import Development.IDE.Types.Monitoring (Monitoring (..)) +import Ide.Logger (Logger) #ifdef MONITORING_EKG import Control.Concurrent (killThread) import Control.Concurrent.Async (async, waitCatch) import Control.Monad (forM_) import Data.Text (pack) -import Development.IDE.Types.Logger (logInfo) +import Ide.Logger (logInfo) import qualified System.Metrics as Monitoring import qualified System.Remote.Monitoring.Wai as Monitoring diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 2a1841131c..1a2c742b68 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -36,7 +36,7 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageE hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 5f3ca5882f..755517375c 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -32,7 +32,7 @@ import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin import qualified Development.IDE.Plugin as P -import Development.IDE.Types.Logger hiding (Error) +import Ide.Logger hiding (Error) import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 0056fb0f7b..c5fa7e0893 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -46,10 +46,10 @@ import Development.IDE.Graph.Classes import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) import Development.IDE.Types.Location (Position (Position, _character, _line), Range (Range, _end, _start)) -import Development.IDE.Types.Logger (Pretty (pretty), +import GHC.Generics (Generic) +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) -import GHC.Generics (Generic) import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types (CommandFunction, diff --git a/ghcide/src/Development/IDE/Types/Action.hs b/ghcide/src/Development/IDE/Types/Action.hs index 462bdc901b..0aedd1d0da 100644 --- a/ghcide/src/Development/IDE/Types/Action.hs +++ b/ghcide/src/Development/IDE/Types/Action.hs @@ -11,12 +11,12 @@ module Development.IDE.Types.Action where import Control.Concurrent.STM -import Data.Hashable (Hashable (..)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Unique (Unique) -import Development.IDE.Graph (Action) -import Development.IDE.Types.Logger +import Data.Hashable (Hashable (..)) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Unique (Unique) +import Development.IDE.Graph (Action) +import Ide.Logger import Numeric.Natural data DelayedAction a = DelayedAction diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs index c51c8bbebc..b84715c1b8 100644 --- a/ghcide/test/exe/HieDbRetry.hs +++ b/ghcide/test/exe/HieDbRetry.hs @@ -1,22 +1,21 @@ {-# LANGUAGE MultiWayIf #-} module HieDbRetry (tests) where -import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, - withVar) -import Control.Exception (ErrorCall (ErrorCall), evaluate, - throwIO, tryJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Tuple.Extra (dupe) -import qualified Database.SQLite.Simple as SQLite -import Development.IDE.Session (retryOnException, - retryOnSqliteBusy) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger (Recorder (Recorder, logger_), - WithPriority (WithPriority, payload), - cmapWithPrio) -import qualified System.Random as Random -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, + withVar) +import Control.Exception (ErrorCall (ErrorCall), evaluate, + throwIO, tryJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Tuple.Extra (dupe) +import qualified Database.SQLite.Simple as SQLite +import Development.IDE.Session (retryOnException, retryOnSqliteBusy) +import qualified Development.IDE.Session as Session +import Ide.Logger (Recorder (Recorder, logger_), + WithPriority (WithPriority, payload), + cmapWithPrio) +import qualified System.Random as Random +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) data Log = LogSession Session.Log diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 1b825e9d0d..e98f5e8612 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -130,7 +130,7 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) -import Development.IDE.Types.Logger (Logger (Logger), +import Ide.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug), diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 64d1aa8263..23e6b85d94 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -40,11 +40,13 @@ library Ide.Plugin.RangeMap Ide.PluginUtils Ide.Types + Ide.Logger hs-source-dirs: src build-depends: , aeson , base >=4.12 && <5 + , co-log-core , containers , data-default , dependent-map @@ -61,10 +63,14 @@ library , lsp ^>=2.0.0.0 , opentelemetry >=0.4 , optparse-applicative + , prettyprinter , regex-tdfa >=1.3.1.0 , row-types + , stm , text + , time , transformers + , unliftio , unordered-containers , megaparsec > 9 diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/hls-plugin-api/src/Ide/Logger.hs similarity index 97% rename from ghcide/src/Development/IDE/Types/Logger.hs rename to hls-plugin-api/src/Ide/Logger.hs index aec4fa3c0a..aab41f4e73 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/hls-plugin-api/src/Ide/Logger.hs @@ -1,11 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | This is a compatibility module that abstracts over the -- concrete choice of logging framework so users can plug in whatever -- framework they want to. -module Development.IDE.Types.Logger +module Ide.Logger ( Priority(..) , Logger(..) , Recorder(..) @@ -65,8 +72,7 @@ import Prettyprinter.Render.Text (renderStrict) import System.IO (Handle, IOMode (AppendMode), hClose, hFlush, openFile, stderr) -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import UnliftIO (MonadUnliftIO, finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 97c0e03fe1..1805a61d82 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -84,17 +84,17 @@ import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import Development.IDE.Types.Options +import GHC.IO.Handle +import GHC.Stack (emptyCallStack) +import GHC.TypeLits +import Ide.Logger (Doc, Logger (Logger), Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, makeDefaultStderrRecorder) -import Development.IDE.Types.Options -import GHC.IO.Handle -import GHC.Stack (emptyCallStack) -import GHC.TypeLits import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index e64c626227..cd1dddbb0c 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -20,8 +20,8 @@ import Development.IDE.GHC.Util (getExtensions) import Development.IDE.Graph.Classes (Hashable, NFData, rnf) import Development.IDE.Spans.Pragmas (NextPragmaInfo, getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) +import Ide.Logger as Logger import Ide.Plugin.Conversion (AlternateFormat, ExtensionNeeded (NeedsExtension, NoExtension), alternateFormat) diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs index 57a40f8411..c7413e1e9a 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -35,7 +35,7 @@ import Development.IDE (Action, IdeAction, import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) -import Development.IDE.Types.Logger (Pretty (..), +import Ide.Logger (Pretty (..), Priority (Warning), logWith) import Ide.Plugin.CodeRange.Rules (CodeRange (..), diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index a1948ce51a..1b78ba74e8 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -6,7 +6,7 @@ import Control.Lens hiding (List, (<.>)) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBSChar8 import Data.String (fromString) -import Development.IDE.Types.Logger (Priority (Debug), +import Ide.Logger (Priority (Debug), Recorder (Recorder), WithPriority (WithPriority), makeDefaultStderrRecorder, diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index f5e9ec6b1d..5084e9750f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -12,7 +12,7 @@ module Ide.Plugin.Eval ( ) where import Development.IDE (IdeState) -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 4413850398..323e3384ec 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -38,7 +38,7 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) #if MIN_VERSION_ghc(9,2,0) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index d5d30de168..faca4a20d5 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -57,9 +57,9 @@ import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, - logWith, (<+>)) import GHC.Generics (Generic) +import Ide.Logger (Priority (..), cmapWithPrio, + logWith, (<+>)) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils (getNormalizedFilePath, diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index eab0c67a9c..76a003d1ef 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -51,7 +51,7 @@ import Development.IDE.GHC.Compat (GenLocated (L), locA, moduleNameString, pattern RealSrcSpan, pm_parsed_source, unLoc) -import Development.IDE.Types.Logger (Pretty (..)) +import Ide.Logger (Pretty (..)) import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 7a743bcdd5..a27abeb32b 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -70,10 +70,10 @@ import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) -import GHC.Generics (Generic) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils (getNormalizedFilePath, diff --git a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs index 6015eedcba..25bfb583b1 100644 --- a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs +++ b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs @@ -13,7 +13,7 @@ import Data.Row import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import Ide.Logger (Doc, Logger (Logger), Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 661f7dbcce..0521e08751 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -81,7 +81,7 @@ import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 727a959620..aef45e552b 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -64,11 +64,11 @@ import Development.IDE.Plugin.Plugins.ImportUtils import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding - (group) import Development.IDE.Types.Options import GHC.Exts (fromList) import qualified GHC.LanguageExtensions as Lang +import Ide.Logger hiding + (group) #if MIN_VERSION_ghc(9,4,0) import GHC.Parser.Annotation (TokenLocation (..)) #endif 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 e7dc3e0142..1e8732c0e3 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -43,7 +43,7 @@ import Development.IDE.GHC.Compat tcg_exports, unLoc) -} import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph.Classes -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import GHC.Generics (Generic) import Ide.Plugin.ExplicitImports (extractMinimalImports, within) diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs index c382082ed0..044061d579 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs @@ -64,7 +64,7 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs index bbde652ae9..f8b62cde72 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs @@ -15,7 +15,7 @@ import Wingman.LanguageServer hiding (Log) import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log = LogWingmanLanguageServer WingmanLanguageServer.Log diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs index 478bf8ecf6..fde8705d55 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs @@ -60,7 +60,7 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs index 5b6cc89150..c8e6c2ae4f 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs @@ -15,7 +15,7 @@ import Wingman.LanguageServer hiding (Log) import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log = LogWingmanLanguageServer WingmanLanguageServer.Log diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 00bb29a630..22008d2a4a 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module HlsPlugins where -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins, diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index d8be0d69f7..6af7551adf 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -20,8 +20,8 @@ module Ide.Arguments import Data.Version import Development.IDE (IdeState) import Development.IDE.Main (Command (..), commandP) -import Development.IDE.Types.Logger (Priority (..)) import GitHash (giHash, tGitInfoCwdTry) +import Ide.Logger (Priority (..)) import Ide.Types (IdePlugins) import Options.Applicative import Paths_haskell_language_server diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index ecfd944b71..b6ee489d7c 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -24,13 +24,13 @@ import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide import GHC.Stack (emptyCallStack) import qualified HIE.Bios.Environment as HieBios -import qualified HIE.Bios.Types as HieBios import HIE.Bios.Types hiding (Log) +import qualified HIE.Bios.Types as HieBios import Ide.Arguments +import Ide.Logger as G import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.Types (IdePlugins, PluginId (PluginId), From 331f73c687206575bd1ae02f552eefc8d8115266 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 18 Jul 2023 22:09:27 +0300 Subject: [PATCH 11/14] Add logging to resolve helpers --- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 131 ++++++++++-------- .../src/Ide/Plugin/ExplicitImports.hs | 32 +++-- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 47 ++++--- .../src/Ide/Plugin/OverloadedRecordDot.hs | 7 +- 4 files changed, 124 insertions(+), 93 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 9f5ab76014..8f8129e781 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} - module Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve, mkCodeActionWithResolveAndCommand) where @@ -19,6 +20,7 @@ import Data.Maybe (catMaybes) import Data.Row ((.!)) import qualified Data.Text as T import GHC.Generics (Generic) +import Ide.Logger import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -29,6 +31,22 @@ import Language.LSP.Server (LspM, LspT, sendRequest, withIndefiniteProgress) +data Log + = LogParseError ResponseError + | LogInvalidParamsError ResponseError + | LogInternalError ResponseError + +instance Pretty Log where + pretty = \case + LogParseError re -> pretty $ re ^. L.message + LogInvalidParamsError re -> pretty $ re ^. L.message + LogInternalError re -> pretty $ re ^. L.message + +logAndThrow :: Recorder (WithPriority Log) -> (ResponseError -> Log) -> ResponseError -> ExceptT ResponseError (LspT Config IO) a +logAndThrow recorder logType err = do + logWith recorder Error (logType err) + throwE err + -- |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 @@ -36,37 +54,38 @@ import Language.LSP.Server (LspM, LspT, -- the client supports resolve and act accordingly in your own providers. mkCodeActionHandlerWithResolve :: forall ideState a. (A.FromJSON a) => - (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + Recorder (WithPriority Log) + -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) -> (ideState -> PluginId -> CodeAction -> Uri -> a -> 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 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 - supportsCodeActionResolve caps -> pure $ InL ls - --This is the actual part where we call resolveCodeAction which fills in the edit data for the client - | otherwise -> InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls - in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) - where - dropData :: CodeAction -> CodeAction +mkCodeActionHandlerWithResolve recorder 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 + supportsCodeActionResolve caps -> pure $ InL ls + --This is the actual part where we call resolveCodeAction which fills in the edit data for the client + | otherwise -> InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls + in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) + where dropData :: CodeAction -> CodeAction dropData ca = ca & L.data_ .~ Nothing resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) resolveCodeAction _uri _ideState _plId c@(InL _) = pure c resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do - case A.fromJSON value of - A.Error err -> throwE $ parseError (Just value) (T.pack err) - A.Success innerValueDecoded -> do - resolveResult <- ExceptT $ codeResolveMethod ideState pid codeAction uri innerValueDecoded - case resolveResult of - CodeAction {_edit = Just _ } -> do - pure $ InR $ dropData resolveResult - _ -> throwE $ invalidParamsError "Returned CodeAction has no data field" - resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwE $ invalidParamsError "CodeAction has no data field" + case A.fromJSON value of + A.Error err -> logAndThrow recorder LogParseError $ parseError (Just value) (T.pack err) + A.Success innerValueDecoded -> do + resolveResult <- ExceptT $ codeResolveMethod ideState pid codeAction uri innerValueDecoded + case resolveResult of + CodeAction {_edit = Just _ } -> do + pure $ InR $ dropData resolveResult + _ -> logAndThrow recorder LogInvalidParamsError $ invalidParamsError "Returned CodeAction has no data field" + resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = logAndThrow recorder LogInvalidParamsError $ invalidParamsError "CodeAction has no data field" + -- |When provided with both a codeAction provider with a data field and a resolve -- provider, this function creates a handler that creates a command that uses @@ -77,26 +96,27 @@ mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = -- either in the original code action or in the resolve will be ignored. mkCodeActionWithResolveAndCommand :: forall ideState a. (A.FromJSON a) => - PluginId + Recorder (WithPriority Log) + -> PluginId -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) -> ([PluginCommand ideState], PluginHandlers ideState) -mkCodeActionWithResolveAndCommand plId 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 - supportsCodeActionResolve caps -> - pure $ InL ls - -- If they do not we will drop the data field, in addition we will populate the command - -- field with our command to execute the resolve, with the whole code action as it's argument. - | otherwise -> pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls - in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)], - mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) +mkCodeActionWithResolveAndCommand recorder plId 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 + supportsCodeActionResolve caps -> + pure $ InL ls + -- If they do not we will drop the data field, in addition we will populate the command + -- field with our command to execute the resolve, with the whole code action as it's argument. + | otherwise -> pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls + in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)], + mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where moveDataToCommand :: Uri -> Command |? CodeAction -> Command |? CodeAction moveDataToCommand uri ca = let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction @@ -113,27 +133,26 @@ mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) where data_ = codeAction ^? L.data_ . _Just executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction))-> CommandFunction ideState CodeAction - executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do - withIndefiniteProgress "Applying edits for code action..." Cancellable $ do + executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do + withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do case A.fromJSON value of - A.Error err -> pure $ Left $ parseError (Just value) (T.pack err) + A.Error err -> logAndThrow recorder LogParseError $ parseError (Just value) (T.pack err) A.Success (WithURI uri innerValue) -> do case A.fromJSON innerValue of - A.Error err -> pure $ Left $ parseError (Just value) (T.pack err) + A.Error err -> logAndThrow recorder LogParseError $ parseError (Just value) (T.pack err) A.Success innerValueDecoded -> do - resolveResult <- resolveProvider ideState plId ca uri innerValueDecoded + resolveResult <- ExceptT $ resolveProvider ideState plId ca uri innerValueDecoded case resolveResult of - Right ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right $ InR Null - Right ca2@CodeAction {_edit = Just _ } -> - pure $ Left $ + ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do + _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) + pure $ InR Null + ca2@CodeAction {_edit = Just _ } -> + logAndThrow recorder LogInternalError $ internalError $ "The resolve provider unexpectedly returned a code action with the following differing fields: " <> (T.pack $ show $ diffCodeActions ca ca2) - Right _ -> pure $ Left $ internalError "The resolve provider unexpectedly returned a result with no data field" - Left err -> pure $ Left err - executeResolveCmd _ _ CodeAction{_data_= value} = pure $ Left $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) + _ -> logAndThrow recorder LogInternalError $ internalError "The resolve provider unexpectedly returned a result with no data field" + executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ logAndThrow recorder LogInvalidParamsError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) -- TODO: Remove once provided by lsp-types 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 5a3e47bf5e..591de48f8c 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitImports ( descriptor , descriptorForModules @@ -61,12 +61,14 @@ importCommandId = "ImportLensCommand" data Log = LogShake Shake.Log | LogWAEResponseError ResponseError - deriving Show + | forall a. (Pretty a) => LogResolve a + instance Pretty Log where pretty = \case LogShake logMsg -> pretty logMsg LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> viaShow rspErr + LogResolve msg -> "ResolveHelpers:" <+> pretty msg -- | The "main" function of a plugin descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -81,7 +83,9 @@ descriptorForModules -> PluginId -> PluginDescriptor IdeState descriptorForModules recorder modFilter plId = - (defaultPluginDescriptor plId) + let resolveRecorder = cmapWithPrio LogResolve recorder + codeActionHandlers = mkCodeActionHandlerWithResolve resolveRecorder (codeActionProvider recorder) (codeActionResolveProvider recorder) + in (defaultPluginDescriptor plId) { -- This plugin provides a command handler pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)], @@ -92,7 +96,7 @@ descriptorForModules recorder modFilter plId = mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) -- This plugin provides code actions - <> mkCodeActionHandlerWithResolve (codeActionProvider recorder) (codeActionResolveProvider recorder) + <> codeActionHandlers } diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 62f2e08094..ade98e846c 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- On 9.4 we get a new redundant constraint warning, but deleting the @@ -153,7 +154,7 @@ data Log | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]] | LogGetIdeas NormalizedFilePath | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them - deriving Show + | forall a. (Pretty a) => LogResolve a instance Pretty Log where pretty = \case @@ -162,6 +163,7 @@ instance Pretty Log where LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp + LogResolve msg -> "ResolveHelpers:" <+> pretty msg #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib @@ -187,7 +189,8 @@ fromStrictMaybe Strict.Nothing = Nothing descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - let (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) + let resolveRecorder = cmapWithPrio LogResolve recorder + (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider (resolveProvider recorder) in (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = pluginCommands diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index d7dd99ac7d..5a2210b226 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -100,16 +100,19 @@ import Language.LSP.Protocol.Types (CodeAction (..), normalizedFilePathToUri, type (|?) (..)) import Language.LSP.Server (getClientCapabilities) + data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] | LogTextEdits [TextEdit] + | forall a. (Pretty a) => LogResolve a instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecordSelectors recs -> "Collected record selectors:" <+> pretty recs + LogResolve msg -> "ResolveHelpers:" <+> pretty msg data CollectRecordSelectors = CollectRecordSelectors deriving (Eq, Show, Generic) @@ -168,7 +171,9 @@ instance FromJSON ORDResolveData descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = let pluginHandler = mkCodeActionHandlerWithResolve codeActionProvider resolveProvider +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + pluginHandler = mkCodeActionHandlerWithResolve resolveRecorder codeActionProvider resolveProvider in (defaultPluginDescriptor plId) { pluginHandlers = pluginHandler , pluginRules = collectRecSelsRule recorder From 4460bd75a99d4eb1abcc17b8d6d2cf2d4bf4b051 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 22 Jul 2023 20:30:00 +0300 Subject: [PATCH 12/14] Implement michaelpj's suggestions --- hls-plugin-api/src/Ide/Plugin/Resolve.hs | 61 +++++++++---------- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- .../src/Ide/Plugin/OverloadedRecordDot.hs | 2 +- 4 files changed, 33 insertions(+), 34 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs index 8f8129e781..73e79a3c14 100644 --- a/hls-plugin-api/src/Ide/Plugin/Resolve.hs +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -32,20 +32,14 @@ import Language.LSP.Server (LspM, LspT, withIndefiniteProgress) data Log - = LogParseError ResponseError - | LogInvalidParamsError ResponseError - | LogInternalError ResponseError - + = DoesNotSupportResolve T.Text + | ApplyWorkspaceEditFailed ResponseError instance Pretty Log where pretty = \case - LogParseError re -> pretty $ re ^. L.message - LogInvalidParamsError re -> pretty $ re ^. L.message - LogInternalError re -> pretty $ re ^. L.message - -logAndThrow :: Recorder (WithPriority Log) -> (ResponseError -> Log) -> ResponseError -> ExceptT ResponseError (LspT Config IO) a -logAndThrow recorder logType err = do - logWith recorder Error (logType err) - throwE err + DoesNotSupportResolve fallback-> + "Client does not support resolve," <+> pretty fallback + ApplyWorkspaceEditFailed err -> + "ApplyWorkspaceEditFailed:" <+> viaShow err -- |When provided with both a codeAction provider and an affiliated codeAction -- resolve provider, this function creates a handler that automatically uses @@ -64,11 +58,13 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = 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 + (InL ls) | -- We don't need to do anything if the client supports + -- resolve supportsCodeActionResolve caps -> pure $ InL ls --This is the actual part where we call resolveCodeAction which fills in the edit data for the client - | otherwise -> InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls + | otherwise -> do + logWith recorder Debug (DoesNotSupportResolve "filling in the code action") + InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) where dropData :: CodeAction -> CodeAction @@ -77,14 +73,14 @@ mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = resolveCodeAction _uri _ideState _plId c@(InL _) = pure c resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do case A.fromJSON value of - A.Error err -> logAndThrow recorder LogParseError $ parseError (Just value) (T.pack err) + A.Error err -> throwE $ parseError (Just value) (T.pack err) A.Success innerValueDecoded -> do resolveResult <- ExceptT $ codeResolveMethod ideState pid codeAction uri innerValueDecoded case resolveResult of CodeAction {_edit = Just _ } -> do pure $ InR $ dropData resolveResult - _ -> logAndThrow recorder LogInvalidParamsError $ invalidParamsError "Returned CodeAction has no data field" - resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = logAndThrow recorder LogInvalidParamsError $ invalidParamsError "CodeAction has no data field" + _ -> throwE $ invalidParamsError "Returned CodeAction has no data field" + resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwE $ invalidParamsError "CodeAction has no data field" -- |When provided with both a codeAction provider with a data field and a resolve @@ -107,13 +103,14 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth 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 - supportsCodeActionResolve caps -> - pure $ InL ls + (InL ls) | -- We don't need to do anything if the client supports + -- resolve + supportsCodeActionResolve caps -> pure $ InL ls -- If they do not we will drop the data field, in addition we will populate the command -- field with our command to execute the resolve, with the whole code action as it's argument. - | otherwise -> pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls + | otherwise -> do + logWith recorder Debug (DoesNotSupportResolve "rewriting the code action to use commands") + pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)], mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) @@ -136,24 +133,26 @@ mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMeth executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do case A.fromJSON value of - A.Error err -> logAndThrow recorder LogParseError $ parseError (Just value) (T.pack err) + A.Error err -> throwE $ parseError (Just value) (T.pack err) A.Success (WithURI uri innerValue) -> do case A.fromJSON innerValue of - A.Error err -> logAndThrow recorder LogParseError $ parseError (Just value) (T.pack err) + A.Error err -> throwE $ parseError (Just value) (T.pack err) A.Success innerValueDecoded -> do resolveResult <- ExceptT $ resolveProvider ideState plId ca uri innerValueDecoded case resolveResult of ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do - _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) + _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback pure $ InR Null ca2@CodeAction {_edit = Just _ } -> - logAndThrow recorder LogInternalError $ - internalError $ + throwE $ internalError $ "The resolve provider unexpectedly returned a code action with the following differing fields: " <> (T.pack $ show $ diffCodeActions ca ca2) - _ -> logAndThrow recorder LogInternalError $ internalError "The resolve provider unexpectedly returned a result with no data field" - executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ logAndThrow recorder LogInvalidParamsError $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) - + _ -> throwE $ internalError "The resolve provider unexpectedly returned a result with no data field" + executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ throwE $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) + handleWEditCallback (Left err ) = do + logWith recorder Warning (ApplyWorkspaceEditFailed err) + pure () + handleWEditCallback _ = pure () -- TODO: Remove once provided by lsp-types -- |Compares two CodeActions and returns a list of fields that are not equal 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 591de48f8c..cc9927291e 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -68,7 +68,7 @@ instance Pretty Log where pretty = \case LogShake logMsg -> pretty logMsg LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> viaShow rspErr - LogResolve msg -> "ResolveHelpers:" <+> pretty msg + LogResolve msg -> pretty msg -- | The "main" function of a plugin descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index ade98e846c..ee59553ab3 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -163,7 +163,7 @@ instance Pretty Log where LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp - LogResolve msg -> "ResolveHelpers:" <+> pretty msg + LogResolve msg -> pretty msg #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 5a2210b226..89ca4e73c9 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -112,7 +112,7 @@ instance Pretty Log where LogShake shakeLog -> pretty shakeLog LogCollectedRecordSelectors recs -> "Collected record selectors:" <+> pretty recs - LogResolve msg -> "ResolveHelpers:" <+> pretty msg + LogResolve msg -> pretty msg data CollectRecordSelectors = CollectRecordSelectors deriving (Eq, Show, Generic) From c00e2da59ad7bb0933f7447cf216e591500f2630 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 22 Jul 2023 22:16:59 +0300 Subject: [PATCH 13/14] Fix test failures --- plugins/hls-code-range-plugin/hls-code-range-plugin.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal index 1e2dfeccad..5a9a858053 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -64,6 +64,7 @@ test-suite tests , filepath , ghcide == 2.1.0.0 , hls-code-range-plugin + , hls-plugin-api , hls-test-utils == 2.1.0.0 , lens , lsp From 1a0c0d6c10c3004ecec4b999067dc9aebe1c42e2 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 22 Jul 2023 22:49:15 +0300 Subject: [PATCH 14/14] fix overloaded-record-dot test --- .../hls-overloaded-record-dot-plugin.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal b/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal index 12884290a0..2ccf3af986 100644 --- a/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal +++ b/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal @@ -62,6 +62,7 @@ test-suite tests , ghcide , text , hls-overloaded-record-dot-plugin + , hls-plugin-api , lens , lsp-test , lsp-types