hls-code-range-plugin 1.0.0.0 → 1.1.0.0
raw patch · 9 files changed
+248/−47 lines, 9 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
+ Ide.Plugin.CodeRange: createFoldingRange :: CodeRange -> Maybe FoldingRange
+ Ide.Plugin.CodeRange: findFoldingRanges :: CodeRange -> [FoldingRange]
+ Ide.Plugin.CodeRange.Rules: crkToFrk :: CodeRangeKind -> FoldingRangeKind
+ Ide.Plugin.CodeRange.Rules: instance GHC.Classes.Eq Ide.Plugin.CodeRange.Rules.CodeRangeKind
Files
- hls-code-range-plugin.cabal +10/−6
- src/Ide/Plugin/CodeRange.hs +123/−26
- src/Ide/Plugin/CodeRange/ASTPreProcess.hs +1/−1
- src/Ide/Plugin/CodeRange/Rules.hs +12/−4
- test/Ide/Plugin/CodeRangeTest.hs +66/−2
- test/Main.hs +34/−8
- test/testdata/selection-range/Empty.golden.txt +0/−0
- test/testdata/selection-range/Empty.hs +1/−0
- test/testdata/selection-range/hie.yaml +1/−0
hls-code-range-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Ide/Plugin/CodeRange.hs view
@@ -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
src/Ide/Plugin/CodeRange/ASTPreProcess.hs view
@@ -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
src/Ide/Plugin/CodeRange/Rules.hs view
@@ -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
test/Ide/Plugin/CodeRangeTest.hs view
@@ -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)))+ ] ]
test/Main.hs view
@@ -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
+ test/testdata/selection-range/Empty.golden.txt view
+ test/testdata/selection-range/Empty.hs view
@@ -0,0 +1,1 @@+module Empty where
test/testdata/selection-range/hie.yaml view
@@ -3,3 +3,4 @@ arguments: - "Import" - "Function"+ - "Empty"