diff --git a/hls-plugin-api.cabal b/hls-plugin-api.cabal --- a/hls-plugin-api.cabal +++ b/hls-plugin-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-plugin-api -version: 2.14.0.0 +version: 2.15.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at @@ -66,7 +66,7 @@ , filepath , ghc , hashable - , hls-graph == 2.14.0.0 + , hls-graph == 2.15.0.0 , lens , lens-aeson , lsp ^>=2.8 diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs --- a/src/Ide/Logger.hs +++ b/src/Ide/Logger.hs @@ -84,7 +84,7 @@ -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). newtype Recorder msg = Recorder - { logger_ :: forall m. (MonadIO m) => msg -> m () } + { logger_ :: forall m. MonadIO m => msg -> m () } logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg) @@ -108,7 +108,7 @@ cmap = contramap cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a) -cmapWithPrio f = cmap (fmap f) +cmapWithPrio = cmap . fmap cmapIO :: (a -> IO b) -> Recorder b -> Recorder a cmapIO f Recorder{ logger_ } = diff --git a/src/Ide/Plugin/Config.hs b/src/Ide/Plugin/Config.hs --- a/src/Ide/Plugin/Config.hs +++ b/src/Ide/Plugin/Config.hs @@ -10,16 +10,18 @@ , CheckParents(..) ) where -import Control.Lens (preview) -import Data.Aeson hiding (Error) -import qualified Data.Aeson as A -import Data.Aeson.Lens (_String) -import qualified Data.Aeson.Types as A +import Control.Applicative +import Control.Lens (preview) +import Data.Aeson hiding (Error) +import qualified Data.Aeson as A +import Data.Aeson.Lens (_String) +import qualified Data.Aeson.Types as A import Data.Default -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import GHC.Exts (toList) +import Data.Functor ((<&>)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import GHC.Exts (toList) import Ide.Types -- --------------------------------------------------------------------- @@ -42,8 +44,16 @@ <*> o .:? "formattingProvider" .!= formattingProvider defValue <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue - <*> o .:? "sessionLoading" .!= sessionLoading defValue + <*> loadingPref o + <*> o .:? "linkSourceTo" .!= linkSourceTo defValue + <*> o .:? "linkDocTo" .!= linkDocTo defValue <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue + where + loadingPref o = + -- We can support "componentsLoading" and the legacy "sessionLoading" option. + (o .:? "componentsLoading" .!= componentsLoading defValue) + <|> (o .:? "sessionLoading" .!= LegacySessionLoadingPreferenceConfig (componentsLoading defValue) + <&> getLegacySessionLoadingPreferenceConfig) -- | Parse the 'PluginConfig'. -- Since we need to fall back to default values if we do not find one in the input, diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -29,6 +29,7 @@ installSigUsr1Handler, subRange, rangesOverlap, + asPosition, positionInRange, usePropertyLsp, -- * Escape @@ -279,8 +280,11 @@ subRange = isSubrangeOf --- | Check whether the two 'Range's overlap in any way. +-- | Check whether the two 'Range's overlap in any way, taking into account +-- that, as per the LSP spec, 'Range's are right-open half-open intervals. -- +-- >>> rangesOverlap (mkRange 1 0 1 2) (mkRange 1 4 1 6) +-- False -- >>> rangesOverlap (mkRange 1 0 1 4) (mkRange 1 2 1 5) -- True -- >>> rangesOverlap (mkRange 1 2 1 5) (mkRange 1 0 1 4) @@ -289,9 +293,22 @@ -- True -- >>> rangesOverlap (mkRange 1 2 1 4) (mkRange 1 0 1 6) -- True +-- >>> rangesOverlap (mkRange 1 2 1 4) (mkRange 1 4 1 6) +-- False rangesOverlap :: Range -> Range -> Bool rangesOverlap r1 r2 = - r1 ^. L.start <= r2 ^. L.end && r2 ^. L.start <= r1 ^. L.end + r1 ^. L.start < r2 ^. L.end && r2 ^. L.start < r1 ^. L.end + +-- | As per the LSP spec, the client's requests come with a 'Range', not a +-- 'Position'. This function attempts to interpret a zero-length 'Range' +-- as position. +-- +-- In practice, it's useful for distinguishing whether the client sent +-- us a cursor position or a selection. +asPosition :: Range -> Maybe Position +asPosition (Range b e) + | b == e = Just b + | otherwise = Nothing -- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -22,7 +22,11 @@ , IdeNotification(..) , IdePlugins(IdePlugins, ipMap) , DynFlagsModifications(..) -, Config(..), PluginConfig(..), CheckParents(..), SessionLoadingPreferenceConfig(..) +, Config(..), PluginConfig(..), CheckParents(..) +, SessionLoadingPreferenceConfig(..) +, LegacySessionLoadingPreferenceConfig(..) +, getLegacySessionLoadingPreferenceConfig +, OptLinkTo(..) , ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin , CustomConfig(..), mkCustomConfig , FallbackCodeActionParams(..) @@ -178,7 +182,9 @@ , formattingProvider :: !T.Text , cabalFormattingProvider :: !T.Text , maxCompletions :: !Int - , sessionLoading :: !SessionLoadingPreferenceConfig + , componentsLoading :: !SessionLoadingPreferenceConfig + , linkSourceTo :: !OptLinkTo + , linkDocTo :: !OptLinkTo , plugins :: !(Map.Map PluginId PluginConfig) } deriving (Show,Eq) @@ -189,7 +195,9 @@ , "formattingProvider" .= formattingProvider , "cabalFormattingProvider" .= cabalFormattingProvider , "maxCompletions" .= maxCompletions - , "sessionLoading" .= sessionLoading + , "componentsLoading" .= componentsLoading + , "linkSourceTo" .= linkSourceTo + , "linkDocTo" .= linkDocTo , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins ] @@ -203,7 +211,9 @@ -- , cabalFormattingProvider = "cabal-fmt" -- this string value needs to kept in sync with the value provided in HlsPlugins , maxCompletions = 40 - , sessionLoading = PreferSingleComponentLoading + , componentsLoading = PreferMultiComponentLoading + , linkSourceTo = LinkToHackage + , linkDocTo = LinkToHackage , plugins = mempty } @@ -217,6 +227,11 @@ deriving anyclass (FromJSON, ToJSON) +data OptLinkTo = LinkToHackage | LinkToLocal + deriving stock (Eq, Ord, Show, Enum, Generic) + deriving anyclass (FromJSON, ToJSON) + + data SessionLoadingPreferenceConfig = PreferSingleComponentLoading -- ^ Always load only a singleComponent when a new component @@ -228,27 +243,70 @@ -- -- The cradle can decide how to handle these situations, and whether -- to honour the preference at all. + | PreferMultiWholeProjectLoading + -- ^ Prefer loading all the components specified in the cradle, if possible. deriving stock (Eq, Ord, Show, Generic) instance Pretty SessionLoadingPreferenceConfig where - pretty PreferSingleComponentLoading = "Prefer Single Component Loading" - pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading" + pretty PreferSingleComponentLoading = "Prefer Single Component Loading" + pretty PreferMultiComponentLoading = "Prefer Multiple Components Loading" + pretty PreferMultiWholeProjectLoading = "Prefer Whole Project Loading" +-- | Labels for @SessionLoadingPreferenceConfig@ json format. +-- +-- 'singleComponent' and 'multipleComponents' are outdated but are maintained here +-- for backwards compatibility. +-- We prefer 'single', 'multiNeededOnly' and 'multiWholeProject' +singleComponent, multipleComponents, single, multiNeededOnly, multiWholeProject :: T.Text +singleComponent = "singleComponent" +multipleComponents = "multipleComponents" +single = "single" +multiNeededOnly = "multi: needed-only" +multiWholeProject = "multi: whole-project" + +-- | Historical artefact! +-- Before HLS 2.15.0.0, the 'SessionLoadingPreferenceConfig' option was called `sessionLoading` with the values +-- `multipleComponents` and `singleComponent`. +-- +-- With HLS 2.15.0.0, we renamed these options and also added some new ones! +-- For backwards compatibility, we support the old naming as well using +-- this backwards compatibility newtype. +newtype LegacySessionLoadingPreferenceConfig = LegacySessionLoadingPreferenceConfig SessionLoadingPreferenceConfig + +getLegacySessionLoadingPreferenceConfig :: LegacySessionLoadingPreferenceConfig -> SessionLoadingPreferenceConfig +getLegacySessionLoadingPreferenceConfig (LegacySessionLoadingPreferenceConfig conf) = conf + instance ToJSON SessionLoadingPreferenceConfig where toJSON PreferSingleComponentLoading = - String "singleComponent" + String single toJSON PreferMultiComponentLoading = - String "multipleComponents" + String multiNeededOnly + toJSON PreferMultiWholeProjectLoading = + String multiWholeProject instance FromJSON SessionLoadingPreferenceConfig where - parseJSON (String val) = case val of - "singleComponent" -> pure PreferSingleComponentLoading - "multipleComponents" -> pure PreferMultiComponentLoading - _ -> A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " - (A.parseFail $ "Expected one of \"singleComponent\" or \"multipleComponents\" but got " <> T.unpack val ) + parseJSON (String val) + | single == val = pure PreferSingleComponentLoading + | multiNeededOnly == val = pure PreferMultiComponentLoading + | multiWholeProject == val = pure PreferMultiWholeProjectLoading + | otherwise = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " + (A.parseFail $ unwords ["Expected one of " ++ expected ++ " but got", T.unpack val] ) + where + expected = T.unpack $ T.intercalate ", " $ map (\ t -> "\'" <> t <> "\'") [single, multiNeededOnly, multiWholeProject] parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " (A.typeMismatch "String" o) +instance FromJSON LegacySessionLoadingPreferenceConfig where + parseJSON (String val) + | singleComponent == val = pure $ LegacySessionLoadingPreferenceConfig PreferSingleComponentLoading + | multipleComponents == val = pure $ LegacySessionLoadingPreferenceConfig PreferMultiComponentLoading + | otherwise = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " + (A.parseFail $ "Expected one of " ++ expected ++ " but got " <> T.unpack val ) + where + expected = T.unpack $ T.intercalate ", " $ map (\ t -> "\'" <> t <> "\'") [singleComponent, multipleComponents] + parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, " + (A.typeMismatch "String" o) + -- | A PluginConfig is a generic configuration for a given HLS plugin. It -- provides a "big switch" to turn it on or off as a whole, as well as small -- switches per feature, and a slot for custom config. @@ -315,8 +373,8 @@ data PluginDescriptor (ideState :: Type) = PluginDescriptor { pluginId :: !PluginId - , pluginDescription :: !T.Text -- ^ Unique identifier of the plugin. + , pluginDescription :: !T.Text , pluginPriority :: Natural -- ^ Plugin handlers are called in priority order, higher priority first , pluginRules :: !(Rules ()) @@ -613,6 +671,9 @@ instance PluginMethod Request (Method_CustomMethod m) where handlesRequest _ _ _ _ _ = HandlesRequest +instance PluginMethod Request Method_WorkspaceWillRenameFiles where + handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf + -- Plugin Notifications instance PluginMethod Notification Method_TextDocumentDidOpen where @@ -635,6 +696,15 @@ -- This method has no URI parameter, thus no call to 'pluginResponsible'. handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf +instance PluginMethod Notification Method_WorkspaceDidDeleteFiles where + handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf + +instance PluginMethod Notification Method_WorkspaceDidRenameFiles where + handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf + +instance PluginMethod Notification Method_WorkspaceDidCreateFiles where + handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf + instance PluginMethod Notification Method_Initialized where -- This method has no URI parameter, thus no call to 'pluginResponsible'. handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf @@ -844,6 +914,8 @@ instance PluginRequestMethod Method_TextDocumentInlayHint where combineResponses _ _ _ _ x = sconcat x +instance PluginRequestMethod Method_WorkspaceWillRenameFiles where + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) @@ -915,6 +987,12 @@ instance PluginNotificationMethod Method_Initialized where +instance PluginNotificationMethod Method_WorkspaceDidDeleteFiles where + +instance PluginNotificationMethod Method_WorkspaceDidCreateFiles where + +instance PluginNotificationMethod Method_WorkspaceDidRenameFiles where + -- --------------------------------------------------------------------- -- | Methods which have a PluginMethod instance @@ -1245,6 +1323,9 @@ instance HasTracing DocumentLink instance HasTracing InlayHint instance HasTracing WorkspaceSymbol +instance HasTracing RenameFilesParams +instance HasTracing DeleteFilesParams +instance HasTracing CreateFilesParams -- --------------------------------------------------------------------- --Experimental resolve refactoring {-# NOINLINE pROCESS_ID #-} diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -155,7 +155,7 @@ gitDiff :: FilePath -> FilePath -> [String] -gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "-w", "--no-index", "--text", "--exit-code", fRef, fNew] +gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-ext-diff", "-w", "--no-index", "--text", "--exit-code", fRef, fNew] goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree goldenGitDiff name = goldenVsStringDiff name gitDiff