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,8 +1,8 @@ cabal-version: 2.4 name: hls-code-range-plugin -version: 1.0.0.0 +version: 1.1.0.0 synopsis: - HLS Plugin to support smart selection range + HLS Plugin to support smart selection range and Folding range description: Please see the README on GitHub at @@ -20,6 +20,10 @@ test/testdata/selection-range/*.yaml test/testdata/selection-range/*.txt +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + library exposed-modules: Ide.Plugin.CodeRange @@ -35,9 +39,9 @@ , containers , deepseq , extra - , ghcide ^>=1.8 + , ghcide ^>=1.9 , hashable - , hls-plugin-api ^>=1.5 + , hls-plugin-api ^>=1.6 , lens , lsp , mtl @@ -60,9 +64,9 @@ , bytestring , containers , filepath - , ghcide ^>=1.8 + , ghcide ^>=1.8 || ^>= 1.9 , hls-code-range-plugin - , hls-test-utils ^>=1.4 + , hls-test-utils ^>=1.5 , 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,5 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange ( descriptor @@ -7,33 +9,38 @@ -- * Internal , findPosition + , findFoldingRanges + , createFoldingRange ) where import Control.Monad.Except (ExceptT (ExceptT), - runExceptT) + mapExceptT) import Control.Monad.IO.Class (liftIO) 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 (IdeAction, +import Development.IDE (Action, IdeAction, IdeState (shakeExtras), Range (Range), Recorder, WithPriority, - cmapWithPrio, + cmapWithPrio, runAction, runIdeAction, toNormalizedFilePath', - uriToFilePath') -import Development.IDE.Core.Actions (useE) + uriToFilePath', use, + useWithStaleFast) import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) -import Development.IDE.Types.Logger (Pretty (..)) +import Development.IDE.Types.Logger (Pretty (..), + Priority (Warning), + logWith) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), - codeRangeRule) + codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) import Ide.PluginUtils (pluginResponse, positionInRange) @@ -41,13 +48,15 @@ PluginId, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Server (LspM) -import Language.LSP.Types (List (List), +import Language.LSP.Server (LspM, LspT) +import Language.LSP.Types (FoldingRange (..), + FoldingRangeParams (..), + List (List), NormalizedFilePath, Position (..), Range (_start), ResponseError, - SMethod (STextDocumentSelectionRange), + SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), TextDocumentIdentifier (TextDocumentIdentifier), @@ -56,47 +65,97 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - -- TODO @sloorush add folding range - -- <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler + { pluginHandlers = mkPluginHandler STextDocumentSelectionRange (selectionRangeHandler recorder) + <> mkPluginHandler STextDocumentFoldingRange (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 -selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) -selectionRangeHandler ide _ SelectionRangeParams{..} = do +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 - selectionRanges <- ExceptT . liftIO . runIdeAction "SelectionRange" (shakeExtras ide) . runExceptT $ - getSelectionRanges filePath positions - pure . List $ selectionRanges + foldingRanges <- mapExceptT runAction' $ + getFoldingRanges filePath + pure . List $ 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 file = do + codeRange <- maybeToExceptT (FoldingRangeBadDependency GetCodeRange) . MaybeT $ use 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 + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + positions :: [Position] List positions = _positions -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange] + 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 "fail to get code range" $ useE GetCodeRange file - -- 'positionMapping' should be appied to the input before using them - positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $ + (codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . MaybeT $ + useWithStaleFast GetCodeRange file + -- 'positionMapping' should be applied to the input before using them + positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . MaybeT . pure $ traverse (fromCurrentPosition positionMapping) positions let selectionRanges = flip fmap positions' $ \pos -> - -- We need a default selection range if the lookup fails, so that other positions can still have valid results. + -- We need a default selection range if the lookup fails, + -- so that other positions can still have valid results. let defaultSelectionRange = SelectionRange (Range pos pos) Nothing in fromMaybe defaultSelectionRange . findPosition pos $ codeRange -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + maybeToExceptT SelectionRangeOutputPositionMappingFailure . MaybeT . pure $ traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. @@ -125,6 +184,44 @@ let (left, right) = V.splitAt (V.length v `div` 2) v startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right + +-- | Traverses through the code range and it children to a folding ranges. +-- +-- It starts with the root node, converts that into a folding range then moves towards the children. +-- It converts each child of each root node and parses it to folding range and moves to its children. +-- +-- Two cases to that are assumed to be taken care on the client side are: +-- +-- 1. When a folding range starts and ends on the same line, it is upto the client if it wants to +-- fold a single line folding or not. +-- +-- 2. As we are converting nodes of the ast into folding ranges, there are multiple nodes starting from a single line. +-- A single line of code doesn't mean a single node in AST, so this function removes all the nodes that have a duplicate +-- start line, ie. they start from the same line. +-- Eg. A multi-line function that also has a multi-line if statement starting from the same line should have the folding +-- according to the function. +-- +-- We think the client can handle this, if not we could change to remove these in future +-- +-- Discussion reference: https://github.com/haskell/haskell-language-server/pull/3058#discussion_r973737211 +findFoldingRanges :: CodeRange -> [FoldingRange] +findFoldingRanges codeRange = + -- removing the first node because it folds the entire file + drop1 $ findFoldingRangesRec codeRange + +findFoldingRangesRec :: CodeRange -> [FoldingRange] +findFoldingRangesRec r@(CodeRange _ children _) = + let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRangesRec children + in case createFoldingRange r of + Just x -> x:frChildren + Nothing -> frChildren + +-- | Parses code range to folding range +createFoldingRange :: CodeRange -> Maybe FoldingRange +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)) -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/src/Ide/Plugin/CodeRange/ASTPreProcess.hs --- a/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +++ b/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -168,7 +168,7 @@ (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) . Map.toList . nodeIdentifiers) --- | Determines if the given occurence of an identifier is a function/variable definition in the outer span +-- | Determines if the given occurrence of an identifier is a function/variable definition in the outer span isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool isIdentADef outerSpan (span, detail) = realSrcSpanStart span >= realSrcSpanStart outerSpan && realSrcSpanEnd span <= realSrcSpanEnd outerSpan 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 @@ -21,6 +21,7 @@ -- * Internal , removeInterleaving , simplify + , crkToFrk ) where import Control.DeepSeq (NFData) @@ -45,14 +46,14 @@ import Development.IDE.Core.Rules (toIdeResult) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HieAST (..), - HieASTs (getAsts), - RefMap) + HieASTs (getAsts), RefMap) import Development.IDE.GHC.Compat.Util import GHC.Generics (Generic) import Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..), PreProcessEnv (..), isCustomNode, preProcessAST) +import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) import Language.LSP.Types.Lens (HasEnd (end), HasStart (start)) import Prelude hiding (log) @@ -90,7 +91,7 @@ | CodeKindImports -- | a comment | CodeKindComment - deriving (Show, Generic, NFData) + deriving (Show, Eq, Generic, NFData) Lens.makeLenses ''CodeRange @@ -187,6 +188,13 @@ valueEither <- runExceptT action' case valueEither of Left msg -> do - logWith recorder Error msg + logWith recorder Warning msg pure $ toIdeResult (Left []) Right value -> pure $ toIdeResult (Right value) + +-- | Maps type CodeRangeKind to FoldingRangeKind +crkToFrk :: CodeRangeKind -> FoldingRangeKind +crkToFrk crk = case crk of + CodeKindComment -> FoldingRangeComment + CodeKindImports -> FoldingRangeImports + CodeKindRegion -> FoldingRangeRegion 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 @@ -17,7 +17,7 @@ mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion - in [ + in [ testCase "not in range" $ check (Position 10 1) (mkCodeRange (Position 1 1) (Position 5 10) []) @@ -50,5 +50,69 @@ ( SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing ) ) - ] + ], + + -- TODO: Some more tests can be added on strange cases like + -- 1. lots of blank lines in between type signature and the body + -- 2. lots of blank lines in the function itself + -- etc. + testGroup "findFoldingRanges" $ + let check :: CodeRange -> [FoldingRange] -> Assertion + check codeRange = (findFoldingRanges codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange + mkCodeRange start end children crk = CodeRange (Range start end) children crk + in [ + -- General test + testCase "Test General Code Block" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) + [], + + -- Tests for code kind + testCase "Test Code Kind Region" $ check + (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)], + 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)], + 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)], + + -- Test for Code Portions with children + testCase "Test Children" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [ + mkCodeRange (Position 1 3) (Position 1 5) [] CodeKindRegion + ] 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) + ] + ], + + testGroup "createFoldingRange" $ + let check :: CodeRange -> Maybe FoldingRange -> Assertion + check codeRange = (createFoldingRange codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange + mkCodeRange start end children crk = CodeRange (Range start end) children crk + in [ + -- 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))), + -- 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))) + ] ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -18,17 +18,18 @@ import System.FilePath ((<.>), ()) import Test.Hls -plugin :: Recorder (WithPriority Log) -> PluginDescriptor IdeState -plugin recorder = descriptor recorder "codeRange" +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor descriptor "codeRange" main :: IO () main = do - recorder <- contramap (fmap pretty) <$> makeDefaultStderrRecorder Nothing Debug defaultTestRunner $ testGroup "Code Range" [ testGroup "Integration Tests" [ - makeSelectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)], - makeSelectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)] + selectionRangeGoldenTest "Import" [(4, 36), (1, 8)], + selectionRangeGoldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)], + selectionRangeGoldenTest "Empty" [(1, 5)], + foldingRangeGoldenTest "Function" ], testGroup "Unit Tests" [ Ide.Plugin.CodeRangeTest.testTree, @@ -36,9 +37,9 @@ ] ] -makeSelectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree -makeSelectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do - res <- runSessionWithServer (plugin recorder) testDataDir $ do +selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree +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) @@ -64,3 +65,28 @@ showPosition :: Position -> ByteString showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" showLBS = fromString . show + +foldingRangeGoldenTest :: TestName -> TestTree +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 + let res = resp ^. result + pure $ fmap showFoldingRangesForTest res + + case res of + Left err -> assertFailure (show err) + Right golden -> pure golden + + where + testDataDir :: FilePath + testDataDir = "test" "testdata" "folding-range" + + showFoldingRangesForTest :: List FoldingRange -> ByteString + showFoldingRangesForTest (List foldingRanges) = LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges + + showFoldingRangeForTest :: FoldingRange -> ByteString + 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 diff --git a/test/testdata/selection-range/Empty.golden.txt b/test/testdata/selection-range/Empty.golden.txt new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/Empty.golden.txt diff --git a/test/testdata/selection-range/Empty.hs b/test/testdata/selection-range/Empty.hs new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/Empty.hs @@ -0,0 +1,1 @@ +module Empty where diff --git a/test/testdata/selection-range/hie.yaml b/test/testdata/selection-range/hie.yaml --- a/test/testdata/selection-range/hie.yaml +++ b/test/testdata/selection-range/hie.yaml @@ -3,3 +3,4 @@ arguments: - "Import" - "Function" + - "Empty"