diff --git a/hls-code-range-plugin.cabal b/hls-code-range-plugin.cabal --- a/hls-code-range-plugin.cabal +++ b/hls-code-range-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-code-range-plugin -version: 2.0.0.1 +version: 2.1.0.0 synopsis: HLS Plugin to support smart selection range and Folding range @@ -37,9 +37,9 @@ , containers , deepseq , extra - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , hashable - , hls-plugin-api == 2.0.0.1 + , hls-plugin-api == 2.1.0.0 , lens , lsp , mtl @@ -62,9 +62,10 @@ , bytestring , containers , filepath - , ghcide == 2.0.0.1 + , ghcide == 2.1.0.0 , hls-code-range-plugin - , hls-test-utils == 2.0.0.1 + , hls-plugin-api + , hls-test-utils == 2.1.0.0 , lens , lsp , lsp-test diff --git a/src/Ide/Plugin/CodeRange.hs b/src/Ide/Plugin/CodeRange.hs --- a/src/Ide/Plugin/CodeRange.hs +++ b/src/Ide/Plugin/CodeRange.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE TypeOperators #-} module Ide.Plugin.CodeRange ( descriptor , Log @@ -13,140 +15,94 @@ , createFoldingRange ) where -import Control.Monad.Except (ExceptT (ExceptT), - mapExceptT) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT, mapExceptT) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) -import Data.Either.Extra (maybeToEither) import Data.List.Extra (drop1) import Data.Maybe (fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V -import Development.IDE (Action, IdeAction, +import Development.IDE (Action, IdeState (shakeExtras), Range (Range), Recorder, WithPriority, - cmapWithPrio, runAction, - runIdeAction, - toNormalizedFilePath', - uriToFilePath', use, - useWithStaleFast) + cmapWithPrio) +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, - fromCurrentPosition, toCurrentRange) -import Development.IDE.Types.Logger (Pretty (..), - Priority (Warning), - logWith) +import Ide.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) -import Ide.PluginUtils (pluginResponse, - positionInRange) +import Ide.Plugin.Error +import Ide.PluginUtils (positionInRange) import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), PluginId, + PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Server (LspM, LspT) -import Language.LSP.Types (FoldingRange (..), +import Language.LSP.Protocol.Message (Method (Method_TextDocumentFoldingRange, Method_TextDocumentSelectionRange), + SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange)) +import Language.LSP.Protocol.Types (FoldingRange (..), FoldingRangeParams (..), - List (List), - NormalizedFilePath, + NormalizedFilePath, Null, Position (..), Range (_start), - ResponseError, - SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri) + Uri, type (|?) (InL)) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange (selectionRangeHandler recorder) - <> mkPluginHandler STextDocumentFoldingRange (foldingRangeHandler recorder) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentSelectionRange (selectionRangeHandler recorder) + <> mkPluginHandler SMethod_TextDocumentFoldingRange (foldingRangeHandler recorder) , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) } data Log = LogRules Rules.Log - | forall rule. Show rule => LogBadDependency rule instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog - LogBadDependency rule -> pretty $ "bad dependency: " <> show rule -foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) -foldingRangeHandler recorder ide _ FoldingRangeParams{..} = do - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - foldingRanges <- mapExceptT runAction' $ - getFoldingRanges filePath - pure . List $ foldingRanges +foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange +foldingRangeHandler _ ide _ FoldingRangeParams{..} = + do + filePath <- getNormalizedFilePathE uri + foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath + pure . InL $ foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument - runAction' :: Action (Either FoldingRangeError [FoldingRange]) -> LspT c IO (Either String [FoldingRange]) - runAction' action = do - result <- liftIO $ runAction "FoldingRange" ide action - case result of - Left err -> case err of - FoldingRangeBadDependency rule -> do - logWith recorder Warning $ LogBadDependency rule - pure $ Right [] - Right list -> pure $ Right list - -data FoldingRangeError = forall rule. Show rule => FoldingRangeBadDependency rule - -getFoldingRanges :: NormalizedFilePath -> ExceptT FoldingRangeError Action [FoldingRange] +getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange] getFoldingRanges file = do - codeRange <- maybeToExceptT (FoldingRangeBadDependency GetCodeRange) . MaybeT $ use GetCodeRange file + codeRange <- useE GetCodeRange file pure $ findFoldingRanges codeRange -selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) -selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - fmap List . mapExceptT runIdeAction' . getSelectionRanges filePath $ positions +selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange +selectionRangeHandler _ ide _ SelectionRangeParams{..} = do + do + filePath <- getNormalizedFilePathE uri + mapExceptT liftIO $ getSelectionRanges ide filePath positions where uri :: Uri TextDocumentIdentifier uri = _textDocument positions :: [Position] - List positions = _positions + positions = _positions - runIdeAction' :: IdeAction (Either SelectionRangeError [SelectionRange]) -> LspT c IO (Either String [SelectionRange]) - runIdeAction' action = do - result <- liftIO $ runIdeAction "SelectionRange" (shakeExtras ide) action - case result of - Left err -> case err of - SelectionRangeBadDependency rule -> do - logWith recorder Warning $ LogBadDependency rule - -- This might happen if the HieAst is not ready, - -- so we give it a default value instead of throwing an error - pure $ Right [] - SelectionRangeInputPositionMappingFailure -> pure $ - Left "failed to apply position mapping to input positions" - SelectionRangeOutputPositionMappingFailure -> pure $ - Left "failed to apply position mapping to output positions" - Right list -> pure $ Right list -data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule - | SelectionRangeInputPositionMappingFailure - | SelectionRangeOutputPositionMappingFailure - -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction [SelectionRange] -getSelectionRanges file positions = do - (codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . MaybeT $ - useWithStaleFast GetCodeRange file +getSelectionRanges :: IdeState -> NormalizedFilePath -> [Position] -> ExceptT PluginError IO ([SelectionRange] |? Null) +getSelectionRanges ide file positions = do + (codeRange, positionMapping) <- runIdeActionE "SelectionRange" (shakeExtras ide) $ useWithStaleFastE GetCodeRange file -- 'positionMapping' should be applied to the input before using them - positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . MaybeT . pure $ - traverse (fromCurrentPosition positionMapping) positions + positions' <- + traverse (fromCurrentPositionE positionMapping) positions let selectionRanges = flip fmap positions' $ \pos -> -- We need a default selection range if the lookup fails, @@ -155,8 +111,8 @@ in fromMaybe defaultSelectionRange . findPosition pos $ codeRange -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT SelectionRangeOutputPositionMappingFailure . MaybeT . pure $ - traverse (toCurrentSelectionRange positionMapping) selectionRanges + maybeToExceptT (PluginInvalidUserState "toCurrentSelectionRange") . MaybeT . pure $ + InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. findPosition :: Position -> CodeRange -> Maybe SelectionRange @@ -221,7 +177,7 @@ createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position lineEnd charEnd)) _ ck) = do -- Type conversion of codeRangeKind to FoldingRangeKind let frk = crkToFrk ck - Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk)) + Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk) Nothing) -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/src/Ide/Plugin/CodeRange/Rules.hs b/src/Ide/Plugin/CodeRange/Rules.hs --- a/src/Ide/Plugin/CodeRange/Rules.hs +++ b/src/Ide/Plugin/CodeRange/Rules.hs @@ -53,8 +53,9 @@ PreProcessEnv (..), isCustomNode, preProcessAST) -import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) -import Language.LSP.Types.Lens (HasEnd (end), +import Language.LSP.Protocol.Types (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region)) + +import Language.LSP.Protocol.Lens (HasEnd (end), HasStart (start)) import Prelude hiding (log) @@ -195,6 +196,6 @@ -- | Maps type CodeRangeKind to FoldingRangeKind crkToFrk :: CodeRangeKind -> FoldingRangeKind crkToFrk crk = case crk of - CodeKindComment -> FoldingRangeComment - CodeKindImports -> FoldingRangeImports - CodeKindRegion -> FoldingRangeRegion + CodeKindComment -> FoldingRangeKind_Comment + CodeKindImports -> FoldingRangeKind_Imports + CodeKindRegion -> FoldingRangeKind_Region diff --git a/test/Ide/Plugin/CodeRangeTest.hs b/test/Ide/Plugin/CodeRangeTest.hs --- a/test/Ide/Plugin/CodeRangeTest.hs +++ b/test/Ide/Plugin/CodeRangeTest.hs @@ -73,17 +73,17 @@ (mkCodeRange (Position 1 1) (Position 5 10) [ mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion ] CodeKindRegion) - [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion)], + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing], testCase "Test Code Kind Comment" $ check (mkCodeRange (Position 1 1) (Position 5 10) [ mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindComment ] CodeKindRegion) - [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeComment)], + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Comment) Nothing], testCase "Test Code Kind Import" $ check (mkCodeRange (Position 1 1) (Position 5 10) [ mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindImports ] CodeKindRegion) - [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeImports)], + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Imports) Nothing], -- Test for Code Portions with children testCase "Test Children" $ check @@ -93,9 +93,9 @@ ] CodeKindRegion, mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion ] CodeKindRegion) - [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), - FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeRegion), - FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion) + [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing, + FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeKind_Region) Nothing, + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing ] ], @@ -109,10 +109,10 @@ -- General tests testCase "Test General Code Block" $ check (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) - (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion))), + (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing)), -- If a range has the same start and end line it need not be folded so Nothing is expected testCase "Test Same Start Line" $ check (mkCodeRange (Position 1 1) (Position 1 10) [] CodeKindRegion) - (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeRegion))) + (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeKind_Region) Nothing)) ] ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,7 +6,7 @@ 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, @@ -14,7 +14,9 @@ import Ide.Plugin.CodeRange (Log, descriptor) import qualified Ide.Plugin.CodeRange.RulesTest import qualified Ide.Plugin.CodeRangeTest -import Language.LSP.Types.Lens +import Language.LSP.Protocol.Lens +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import System.FilePath ((<.>), ()) import Test.Hls @@ -41,19 +43,20 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do res <- runSessionWithServer plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" - resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc - (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) + resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc + $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions let res = resp ^. result - pure $ fmap showSelectionRangesForTest res + pure $ fmap (showSelectionRangesForTest . absorbNull) res case res of + Left (ResponseError (InL LSPErrorCodes_RequestFailed) _ _) -> pure "" Left err -> assertFailure (show err) Right golden -> pure golden where testDataDir :: FilePath testDataDir = "test" "testdata" "selection-range" - showSelectionRangesForTest :: List SelectionRange -> ByteString - showSelectionRangesForTest (List selectionRanges) = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges + showSelectionRangesForTest :: [SelectionRange] -> ByteString + showSelectionRangesForTest selectionRanges = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges showSelectionRangeForTest :: SelectionRange -> ByteString showSelectionRangeForTest selectionRange = go True (Just selectionRange) @@ -70,9 +73,9 @@ foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do res <- runSessionWithServer plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" - resp <- request STextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc + resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc let res = resp ^. result - pure $ fmap showFoldingRangesForTest res + pure $ fmap (showFoldingRangesForTest . absorbNull) res case res of Left err -> assertFailure (show err) @@ -82,11 +85,11 @@ testDataDir :: FilePath testDataDir = "test" "testdata" "folding-range" - showFoldingRangesForTest :: List FoldingRange -> ByteString - showFoldingRangesForTest (List foldingRanges) = LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges + showFoldingRangesForTest :: [FoldingRange] -> ByteString + showFoldingRangesForTest foldingRanges = (LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges) `LBSChar8.snoc` '\n' showFoldingRangeForTest :: FoldingRange -> ByteString - showFoldingRangeForTest f@(FoldingRange sl (Just sc) el (Just ec) (Just frk)) = "((" <> showLBS sl <>", "<> showLBS sc <> ")" <> " : " <> "(" <> showLBS el <>", "<> showLBS ec<> ")) : " <> showFRK frk + showFoldingRangeForTest f@(FoldingRange sl (Just sc) el (Just ec) (Just frk) _) = "((" <> showLBS sl <>", "<> showLBS sc <> ")" <> " : " <> "(" <> showLBS el <>", "<> showLBS ec<> ")) : " <> showFRK frk showLBS = fromString . show showFRK = fromString . show