From 098882de15d0d5901005714b5f5d7eb843dc2ab9 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sun, 24 Jul 2022 03:55:21 +0530 Subject: [PATCH 01/31] save some progress: add basic starter code for folding ranges --- .../src/Ide/Plugin/CodeRange.hs | 27 ++++++++++++++++--- 1 file changed, 23 insertions(+), 4 deletions(-) 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 0a48a3467b..22b34b595c 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -47,18 +47,20 @@ import Language.LSP.Types (List (List), Position (..), Range (_start), ResponseError, - SMethod (STextDocumentSelectionRange), + SMethod (STextDocumentSelectionRange, STextDocumentFoldingRange), SelectionRange (..), SelectionRangeParams (..), + FoldingRange (..), + FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri) + Uri + ) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - -- TODO @sloorush add folding range - -- <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler + <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) } @@ -68,6 +70,23 @@ instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog +foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) +foldingRangeHandler ide _ FoldingRangeParams{..} = do + pluginResponse $ do + filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ + getFoldingRanges filePath + pure . List $ foldingRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + +getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] +getFoldingRanges file = do + codeRange <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file + -- let foldingRanges = + selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do pluginResponse $ do From 2e44b7ac6f241be8d938e5a1365893d612b66e41 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sat, 6 Aug 2022 13:58:10 +0530 Subject: [PATCH 02/31] save some progress: add function to traverse through coderange and form folding ranges --- .../src/Ide/Plugin/CodeRange.hs | 59 +++++++++++++++++-- 1 file changed, 54 insertions(+), 5 deletions(-) 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 22b34b595c..34c43123e5 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -33,7 +33,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, import Development.IDE.Types.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), - codeRangeRule) + codeRangeRule, CodeRangeKind (CodeKindRegion)) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) import Ide.PluginUtils (pluginResponse, positionInRange) @@ -82,10 +82,31 @@ foldingRangeHandler ide _ FoldingRangeParams{..} = do uri :: Uri TextDocumentIdentifier uri = _textDocument -getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] -getFoldingRanges file = do - codeRange <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - -- let foldingRanges = +-- getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] +-- getFoldingRanges file = do +-- codeRange <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file +-- let foldingRanges = +-- -- get code range tree +-- -- return folding range +-- -- gg + +getFoldingRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [FoldingRange] +getFoldingRanges 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 $ + traverse (fromCurrentPosition positionMapping) positions + + let foldingRanges = flip fmap positions' $ \pos -> + -- We need a default folding range if the lookup fails, so that other positions can still have valid results. + let defaultFoldingRange = FoldingRange (0 pos pos) Nothing + -- TODO: Fix the return of find position folding range + in fromMaybe defaultFoldingRange . findPositionFoldingRange pos $ codeRange + + -- TODO: Port this to traverse folding range + -- 'positionMapping' should be applied to the output ranges before returning them + maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + traverse (toCurrentSelectionRange positionMapping) foldingRanges selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do @@ -145,6 +166,34 @@ findPosition pos root = go Nothing root startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right +findPositionFoldingRange :: Position -> CodeRange -> Maybe FoldingRange +findPositionFoldingRange pos root = go Nothing root + where + -- Helper function for recursion. The range list is built top-down + go :: Maybe FoldingRange -> CodeRange -> Maybe FoldingRange + go acc node = + if positionInRange pos range + then maybe acc' (go acc') (binarySearchPos children) + else Nothing + where + range = _codeRange_range node + children = _codeRange_children node + Range startPos endPos = range + Position lineStart _=startPos + Position lineEnd _ =endPos + -- (Maybe FoldingRangeKind) + acc'=Just $ maybe (FoldingRange lineStart 0 lineEnd 0 0) acc + -- todo: fix type situation of folding range + binarySearchPos :: Vector CodeRange -> Maybe CodeRange + binarySearchPos v + | V.null v = Nothing + | V.length v == 1, + Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing + | otherwise = do + 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 + -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange toCurrentSelectionRange positionMapping SelectionRange{..} = do From fec18246d8a5da155e1b5507cd29a8d76a3bfd14 Mon Sep 17 00:00:00 2001 From: sloorush Date: Tue, 9 Aug 2022 16:31:22 +0530 Subject: [PATCH 03/31] save some progress: add parsing of folding ranges --- .../src/Ide/Plugin/CodeRange.hs | 70 +++++++------------ 1 file changed, 24 insertions(+), 46 deletions(-) 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 34c43123e5..8b1261689b 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -33,7 +33,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, import Development.IDE.Types.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), - codeRangeRule, CodeRangeKind (CodeKindRegion)) + codeRangeRule) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) import Ide.PluginUtils (pluginResponse, positionInRange) @@ -70,7 +70,7 @@ instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog -foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) +foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List (FoldingRange))) foldingRangeHandler ide _ FoldingRangeParams{..} = do pluginResponse $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ @@ -82,31 +82,18 @@ foldingRangeHandler ide _ FoldingRangeParams{..} = do uri :: Uri TextDocumentIdentifier uri = _textDocument --- getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] --- getFoldingRanges file = do --- codeRange <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file --- let foldingRanges = --- -- get code range tree --- -- return folding range --- -- gg - -getFoldingRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [FoldingRange] -getFoldingRanges 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 $ - traverse (fromCurrentPosition positionMapping) positions + -- let foldingRanges = findFoldingRanges codeRange +getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] +getFoldingRanges file = do + (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - let foldingRanges = flip fmap positions' $ \pos -> - -- We need a default folding range if the lookup fails, so that other positions can still have valid results. - let defaultFoldingRange = FoldingRange (0 pos pos) Nothing - -- TODO: Fix the return of find position folding range - in fromMaybe defaultFoldingRange . findPositionFoldingRange pos $ codeRange + -- We need a default selection range if the lookup fails, so that other positions can still have valid results. + let foldingRanges = let defaultFoldingRange = FoldingRange (0 0 0) Nothing + in fromMaybe defaultFoldingRange . findFoldingRanges codeRange - -- TODO: Port this to traverse folding range - -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ - traverse (toCurrentSelectionRange positionMapping) foldingRanges + -- let foldingRanges = fromMaybe defaultFoldingRange . findFoldingRanges codeRange + + maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do @@ -166,33 +153,24 @@ findPosition pos root = go Nothing root startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right -findPositionFoldingRange :: Position -> CodeRange -> Maybe FoldingRange -findPositionFoldingRange pos root = go Nothing root +appendFoldingRanges :: Maybe FoldingRange -> [Maybe FoldingRange] -> [Maybe FoldingRange] +appendFoldingRanges a [] = [a] +appendFoldingRanges a (x:xs) = x : appendFoldingRanges a xs + +findFoldingRanges :: CodeRange -> [Maybe FoldingRange] +findFoldingRanges root = go [] root where -- Helper function for recursion. The range list is built top-down - go :: Maybe FoldingRange -> CodeRange -> Maybe FoldingRange - go acc node = - if positionInRange pos range - then maybe acc' (go acc') (binarySearchPos children) - else Nothing + go :: [Maybe FoldingRange] -> CodeRange -> [Maybe FoldingRange] + go acc node = do + let acc' = appendFoldingRanges (Just $ FoldingRange lineStart 0 lineEnd 0 0) acc + go (acc' children) where range = _codeRange_range node children = _codeRange_children node Range startPos endPos = range - Position lineStart _=startPos - Position lineEnd _ =endPos - -- (Maybe FoldingRangeKind) - acc'=Just $ maybe (FoldingRange lineStart 0 lineEnd 0 0) acc - -- todo: fix type situation of folding range - binarySearchPos :: Vector CodeRange -> Maybe CodeRange - binarySearchPos v - | V.null v = Nothing - | V.length v == 1, - Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing - | otherwise = do - 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 + Position lineStart _= startPos + Position lineEnd _ = endPos -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange From f9ffcc1024a96816864a7194496b4f72b67578f5 Mon Sep 17 00:00:00 2001 From: sloorush Date: Tue, 9 Aug 2022 18:16:40 +0530 Subject: [PATCH 04/31] fix: maybe issue with foldingRanges --- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) 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 8b1261689b..17c5839cb4 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -56,6 +56,7 @@ import Language.LSP.Types (List (List), Uri ) import Prelude hiding (log, span) +import Data.Maybe (catMaybes) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) @@ -82,16 +83,11 @@ foldingRangeHandler ide _ FoldingRangeParams{..} = do uri :: Uri TextDocumentIdentifier uri = _textDocument - -- let foldingRanges = findFoldingRanges codeRange getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] getFoldingRanges file = do (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - -- We need a default selection range if the lookup fails, so that other positions can still have valid results. - let foldingRanges = let defaultFoldingRange = FoldingRange (0 0 0) Nothing - in fromMaybe defaultFoldingRange . findFoldingRanges codeRange - - -- let foldingRanges = fromMaybe defaultFoldingRange . findFoldingRanges codeRange + let foldingRanges = catMaybes $ findFoldingRanges codeRange maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) From 1d28a2c961448c3c5865bd17ab3b8b018abe52d6 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 10 Aug 2022 01:19:33 +0530 Subject: [PATCH 05/31] add: generate folding ranges from coderange --- .../src/Ide/Plugin/CodeRange.hs | 55 ++++++++++++------- .../src/Ide/Plugin/CodeRange/Rules.hs | 2 +- 2 files changed, 37 insertions(+), 20 deletions(-) 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 17c5839cb4..ae7f45abdb 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -33,7 +33,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, import Development.IDE.Types.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), - codeRangeRule) + codeRangeRule, CodeRangeKind (CodeKindComment, CodeKindImports, CodeKindRegion)) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) import Ide.PluginUtils (pluginResponse, positionInRange) @@ -53,7 +53,7 @@ import Language.LSP.Types (List (List), FoldingRange (..), FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri + Uri, FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion) ) import Prelude hiding (log, span) import Data.Maybe (catMaybes) @@ -149,24 +149,41 @@ findPosition pos root = go Nothing root startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right -appendFoldingRanges :: Maybe FoldingRange -> [Maybe FoldingRange] -> [Maybe FoldingRange] -appendFoldingRanges a [] = [a] -appendFoldingRanges a (x:xs) = x : appendFoldingRanges a xs - findFoldingRanges :: CodeRange -> [Maybe FoldingRange] -findFoldingRanges root = go [] root - where - -- Helper function for recursion. The range list is built top-down - go :: [Maybe FoldingRange] -> CodeRange -> [Maybe FoldingRange] - go acc node = do - let acc' = appendFoldingRanges (Just $ FoldingRange lineStart 0 lineEnd 0 0) acc - go (acc' children) - where - range = _codeRange_range node - children = _codeRange_children node - Range startPos endPos = range - Position lineStart _= startPos - Position lineEnd _ = endPos +findFoldingRanges root = do + let acc = [] + let node = _codeRange_children root + binarySearch node acc + +makeFoldFromNode :: CodeRange -> Maybe FoldingRange +makeFoldFromNode node1 = do + let range = _codeRange_range node1 + -- let children = _codeRange_children node1 + let Range startPos endPos = range + let Position lineStart _= startPos + let Position lineEnd _ = endPos + let codeRangeKind = _codeRange_kind node1 + + if codeRangeKind == CodeKindComment + then Just (FoldingRange lineStart Nothing lineEnd Nothing (Just FoldingRangeComment)) + else if codeRangeKind== CodeKindImports + then Just (FoldingRange lineStart Nothing lineEnd Nothing ( Just FoldingRangeImports)) + else if codeRangeKind==CodeKindRegion + then Just (FoldingRange lineStart Nothing lineEnd Nothing (Just FoldingRangeRegion)) + else Nothing + +binarySearch :: Vector CodeRange -> [Maybe FoldingRange] -> [Maybe FoldingRange] +binarySearch v acc + | V.null v = [] + | V.length v == 1 = do + headi <- V.headM v + let foldingRangesOfRange = makeFoldFromNode headi + let acc' = acc ++ [foldingRangesOfRange] + acc' + | otherwise = do + let (left, right) = V.splitAt (V.length v `div` 2) v + _ <-binarySearch left acc + binarySearch right acc -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 8a573d9ebb..35f303d493 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -91,7 +91,7 @@ data CodeRangeKind = | CodeKindImports -- | a comment | CodeKindComment - deriving (Show, Generic, NFData) + deriving (Show, Eq, Generic, NFData) Lens.makeLenses ''CodeRange From 60b213665c7952d4282cbe4549fce3b7a5939b2c Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 10 Aug 2022 02:46:48 +0530 Subject: [PATCH 06/31] add: plugin request method instance for folding ranges --- hls-plugin-api/src/Ide/Plugin/Config.hs | 6 +++++- hls-plugin-api/src/Ide/Types.hs | 10 ++++++++++ .../hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs | 5 ++--- 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 8aaafd9849..6d5e8e41d5 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -110,6 +110,7 @@ data PluginConfig = , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool + , plcFoldingRangeOn :: !Bool , plcConfig :: !A.Object } deriving (Show,Eq) @@ -125,11 +126,12 @@ instance Default PluginConfig where , plcCompletionOn = True , plcRenameOn = True , plcSelectionRangeOn = True + , plcFoldingRangeOn = True , plcConfig = mempty } instance A.ToJSON PluginConfig where - toJSON (PluginConfig g ch ca cl d h s c rn sr cfg) = r + toJSON (PluginConfig g ch ca cl d h s c rn sr fr cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch @@ -141,6 +143,7 @@ instance A.ToJSON PluginConfig where , "completionOn" .= c , "renameOn" .= rn , "selectionRangeOn" .= sr + , "foldingRangeOn" .= fr , "config" .= cfg ] @@ -156,6 +159,7 @@ instance A.FromJSON PluginConfig where <*> o .:? "completionOn" .!= plcCompletionOn def <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def + <*> o .:? "selectionRangeOn" .!= plcFoldingRangeOn def <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 7d60fd281d..1a42892a8c 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -370,6 +370,13 @@ instance PluginMethod Request TextDocumentSelectionRange where uri = msgParams ^. J.textDocument . J.uri pid = pluginId pluginDesc +instance PluginMethod Request TextDocumentFoldingRange where + pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc + && pluginEnabledConfig plcFoldingRangeOn pid conf + where + uri = msgParams ^. J.textDocument . J.uri + pid = pluginId pluginDesc + instance PluginMethod Request CallHierarchyIncomingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible' pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn pid conf @@ -470,6 +477,9 @@ instance PluginRequestMethod TextDocumentPrepareCallHierarchy where instance PluginRequestMethod TextDocumentSelectionRange where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod TextDocumentFoldingRange where + combineResponses _ _ _ _ (x :| _) = x + instance PluginRequestMethod CallHierarchyIncomingCalls where instance PluginRequestMethod CallHierarchyOutgoingCalls where 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 ae7f45abdb..3f88797ec4 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -15,7 +15,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) -import Data.Maybe (fromMaybe) +import Data.Maybe ( fromMaybe, catMaybes ) import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE (IdeAction, @@ -56,7 +56,6 @@ import Language.LSP.Types (List (List), Uri, FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion) ) import Prelude hiding (log, span) -import Data.Maybe (catMaybes) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) @@ -71,7 +70,7 @@ instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog -foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List (FoldingRange))) +foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) foldingRangeHandler ide _ FoldingRangeParams{..} = do pluginResponse $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ From 02a1e9d26f012075bbda25793650ce9c6510bd74 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 10 Aug 2022 03:59:18 +0530 Subject: [PATCH 07/31] ref: alter function and var names --- .../src/Ide/Plugin/CodeRange.hs | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) 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 3f88797ec4..7e33213fcc 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -152,10 +152,23 @@ findFoldingRanges :: CodeRange -> [Maybe FoldingRange] findFoldingRanges root = do let acc = [] let node = _codeRange_children root - binarySearch node acc + binarySearchFoldingRange node acc -makeFoldFromNode :: CodeRange -> Maybe FoldingRange -makeFoldFromNode node1 = do +binarySearchFoldingRange :: Vector CodeRange -> [Maybe FoldingRange] -> [Maybe FoldingRange] +binarySearchFoldingRange v acc + | V.null v = [] + | V.length v == 1 = do + headOfCodeRange <- V.headM v + let foldingRangesOfRange = createFoldingRange headOfCodeRange + let acc' = acc ++ [foldingRangesOfRange] + acc' + | otherwise = do + let (left, right) = V.splitAt (V.length v `div` 2) v + _ <- binarySearchFoldingRange left acc + binarySearchFoldingRange right acc + +createFoldingRange :: CodeRange -> Maybe FoldingRange +createFoldingRange node1 = do let range = _codeRange_range node1 -- let children = _codeRange_children node1 let Range startPos endPos = range @@ -171,19 +184,6 @@ makeFoldFromNode node1 = do then Just (FoldingRange lineStart Nothing lineEnd Nothing (Just FoldingRangeRegion)) else Nothing -binarySearch :: Vector CodeRange -> [Maybe FoldingRange] -> [Maybe FoldingRange] -binarySearch v acc - | V.null v = [] - | V.length v == 1 = do - headi <- V.headM v - let foldingRangesOfRange = makeFoldFromNode headi - let acc' = acc ++ [foldingRangesOfRange] - acc' - | otherwise = do - let (left, right) = V.splitAt (V.length v `div` 2) v - _ <-binarySearch left acc - binarySearch right acc - -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange toCurrentSelectionRange positionMapping SelectionRange{..} = do From a032c78d2183ca50bc01f5f9b82e71fdfa127f96 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 10 Aug 2022 22:53:47 +0530 Subject: [PATCH 08/31] post review: cleanup crk to frk & fix typo --- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 17 +++++++---------- .../src/Ide/Plugin/CodeRange/Rules.hs | 10 ++++++++++ 3 files changed, 18 insertions(+), 11 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 6d5e8e41d5..e7cbb5ccdb 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -159,7 +159,7 @@ instance A.FromJSON PluginConfig where <*> o .:? "completionOn" .!= plcCompletionOn def <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def - <*> o .:? "selectionRangeOn" .!= plcFoldingRangeOn def + <*> o .:? "foldingRangeOn" .!= plcFoldingRangeOn def <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- 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 7e33213fcc..c6fbbffa71 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -33,7 +33,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, import Development.IDE.Types.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), - codeRangeRule, CodeRangeKind (CodeKindComment, CodeKindImports, CodeKindRegion)) + codeRangeRule, crkToFrk) import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) import Ide.PluginUtils (pluginResponse, positionInRange) @@ -53,7 +53,7 @@ import Language.LSP.Types (List (List), FoldingRange (..), FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri, FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion) + Uri ) import Prelude hiding (log, span) @@ -170,19 +170,16 @@ binarySearchFoldingRange v acc createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange node1 = do let range = _codeRange_range node1 - -- let children = _codeRange_children node1 let Range startPos endPos = range let Position lineStart _= startPos let Position lineEnd _ = endPos let codeRangeKind = _codeRange_kind node1 - if codeRangeKind == CodeKindComment - then Just (FoldingRange lineStart Nothing lineEnd Nothing (Just FoldingRangeComment)) - else if codeRangeKind== CodeKindImports - then Just (FoldingRange lineStart Nothing lineEnd Nothing ( Just FoldingRangeImports)) - else if codeRangeKind==CodeKindRegion - then Just (FoldingRange lineStart Nothing lineEnd Nothing (Just FoldingRangeRegion)) - else Nothing + let frk = crkToFrk codeRangeKind + + case frk of + Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) + Nothing -> Nothing -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 35f303d493..c52f796b72 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -21,6 +21,7 @@ module Ide.Plugin.CodeRange.Rules -- * Internal , removeInterleaving , simplify + , crkToFrk ) where import Control.DeepSeq (NFData) @@ -57,6 +58,7 @@ import Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..), import Language.LSP.Types.Lens (HasEnd (end), HasStart (start)) import Prelude hiding (log) +import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) data Log = LogShake Shake.Log | LogNoAST @@ -193,3 +195,11 @@ handleError recorder action' = do logWith recorder Error msg pure $ toIdeResult (Left []) Right value -> pure $ toIdeResult (Right value) + +-- | Maps type CodeRangeKind to FoldingRangeKind +crkToFrk :: CodeRangeKind -> Maybe FoldingRangeKind +crkToFrk crk = case crk of + CodeKindComment -> Just FoldingRangeComment + CodeKindImports -> Just FoldingRangeImports + CodeKindRegion -> Just FoldingRangeRegion + _ -> Nothing \ No newline at end of file From 892a1295f94891ed4147ba3c50c904648c2ca608 Mon Sep 17 00:00:00 2001 From: sloorush Date: Fri, 12 Aug 2022 16:13:38 +0530 Subject: [PATCH 09/31] fix: find folding ranges function --- .../src/Ide/Plugin/CodeRange.hs | 29 +++++++------------ 1 file changed, 10 insertions(+), 19 deletions(-) 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 c6fbbffa71..ca20e1c01f 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange ( descriptor @@ -86,7 +87,7 @@ getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange getFoldingRanges file = do (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - let foldingRanges = catMaybes $ findFoldingRanges codeRange + let foldingRanges = findFoldingRanges codeRange maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) @@ -148,24 +149,14 @@ findPosition pos root = go Nothing root startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right -findFoldingRanges :: CodeRange -> [Maybe FoldingRange] -findFoldingRanges root = do - let acc = [] - let node = _codeRange_children root - binarySearchFoldingRange node acc - -binarySearchFoldingRange :: Vector CodeRange -> [Maybe FoldingRange] -> [Maybe FoldingRange] -binarySearchFoldingRange v acc - | V.null v = [] - | V.length v == 1 = do - headOfCodeRange <- V.headM v - let foldingRangesOfRange = createFoldingRange headOfCodeRange - let acc' = acc ++ [foldingRangesOfRange] - acc' - | otherwise = do - let (left, right) = V.splitAt (V.length v `div` 2) v - _ <- binarySearchFoldingRange left acc - binarySearchFoldingRange right acc +findFoldingRanges :: CodeRange -> [FoldingRange] +findFoldingRanges r@(CodeRange _ children _) = + let frRoot :: [FoldingRange] = case createFoldingRange r of + Just x -> [x] + Nothing -> [] + + frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children + in frRoot ++ frChildren createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange node1 = do From e6a2b5ca3e8232bc082ce84d22545a5bd462a2ff Mon Sep 17 00:00:00 2001 From: sloorush Date: Fri, 12 Aug 2022 16:14:37 +0530 Subject: [PATCH 10/31] format: run formatter and add comments --- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 165 ++++++++------- .../src/Ide/Plugin/CodeRange/ASTPreProcess.hs | 182 ++++++++-------- .../src/Ide/Plugin/CodeRange/Rules.hs | 195 +++++++++--------- .../src/Ide/Plugin/Eval/Config.hs | 4 +- 5 files changed, 284 insertions(+), 264 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index e7cbb5ccdb..13f33278a8 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -110,7 +110,7 @@ data PluginConfig = , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool - , plcFoldingRangeOn :: !Bool + , plcFoldingRangeOn :: !Bool , plcConfig :: !A.Object } deriving (Show,Eq) 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 ca20e1c01f..3e2512658c 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ide.Plugin.CodeRange ( - descriptor - , Log +module Ide.Plugin.CodeRange + ( descriptor, + Log, -- * Internal - , findPosition - ) where + findPosition, + ) +where import Control.Monad.Except (ExceptT (ExceptT), runExceptT) @@ -16,7 +17,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) -import Data.Maybe ( fromMaybe, catMaybes ) +import Data.Maybe (fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE (IdeAction, @@ -43,62 +44,67 @@ import Ide.Types (PluginDescriptor (pluginH defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Server (LspM) -import Language.LSP.Types (List (List), +import Language.LSP.Types (FoldingRange (..), + FoldingRangeParams (..), + List (List), NormalizedFilePath, Position (..), Range (_start), ResponseError, - SMethod (STextDocumentSelectionRange, STextDocumentFoldingRange), + SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), - FoldingRange (..), - FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri - ) + Uri) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler - , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) +descriptor recorder plId = + (defaultPluginDescriptor plId) + { pluginHandlers = + mkPluginHandler STextDocumentSelectionRange selectionRangeHandler + <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler, + pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) } data Log = LogRules Rules.Log instance Pretty Log where - pretty log = case log of - LogRules codeRangeLog -> pretty codeRangeLog + pretty log = case log of + LogRules codeRangeLog -> pretty codeRangeLog foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) -foldingRangeHandler ide _ FoldingRangeParams{..} = do - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ - getFoldingRanges filePath - pure . List $ foldingRanges - where - uri :: Uri - TextDocumentIdentifier uri = _textDocument +foldingRangeHandler ide _ FoldingRangeParams {..} = do + pluginResponse $ do + filePath <- + ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + foldingRanges <- + ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ + getFoldingRanges filePath + pure . List $ foldingRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] getFoldingRanges file = do - (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file + (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - let foldingRanges = findFoldingRanges codeRange + let foldingRanges = findFoldingRanges codeRange - maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) + maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) -selectionRangeHandler ide _ SelectionRangeParams{..} = 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 +selectionRangeHandler ide _ SelectionRangeParams {..} = 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 where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -108,19 +114,20 @@ selectionRangeHandler ide _ SelectionRangeParams{..} = do getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String 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 $ - traverse (fromCurrentPosition positionMapping) positions + (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 $ + 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. - let defaultSelectionRange = SelectionRange (Range pos pos) Nothing - in fromMaybe defaultSelectionRange . findPosition pos $ codeRange + 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. + 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 $ - traverse (toCurrentSelectionRange positionMapping) selectionRanges + -- 'positionMapping' should be applied to the output ranges before returning them + maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + 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 @@ -129,11 +136,11 @@ findPosition pos root = go Nothing root -- Helper function for recursion. The range list is built top-down go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange go acc node = - if positionInRange pos range + if positionInRange pos range then maybe acc' (go acc') (binarySearchPos children) - -- If all children doesn't contain pos, acc' will be returned. + else -- If all children doesn't contain pos, acc' will be returned. -- acc' will be Nothing only if we are in the root level. - else Nothing + Nothing where range = _codeRange_range node children = _codeRange_children node @@ -141,42 +148,46 @@ findPosition pos root = go Nothing root binarySearchPos :: Vector CodeRange -> Maybe CodeRange binarySearchPos v - | V.null v = Nothing - | V.length v == 1, - Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing - | otherwise = do - 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 - + | V.null v = Nothing + | V.length v == 1, + Just r <- V.headM v = + if positionInRange pos (_codeRange_range r) then Just r else Nothing + | otherwise = do + 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 children to a folding ranges findFoldingRanges :: CodeRange -> [FoldingRange] findFoldingRanges r@(CodeRange _ children _) = let frRoot :: [FoldingRange] = case createFoldingRange r of - Just x -> [x] + Just x -> [x] Nothing -> [] frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children in frRoot ++ frChildren +-- | Parses code range to folding range createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange node1 = do - let range = _codeRange_range node1 - let Range startPos endPos = range - let Position lineStart _= startPos - let Position lineEnd _ = endPos - let codeRangeKind = _codeRange_kind node1 + let range = _codeRange_range node1 + let Range startPos endPos = range + let Position lineStart _ = startPos + let Position lineEnd _ = endPos + let codeRangeKind = _codeRange_kind node1 - let frk = crkToFrk codeRangeKind + let frk = crkToFrk codeRangeKind - case frk of - Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) - Nothing -> Nothing + case frk of + Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) + Nothing -> Nothing -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange -toCurrentSelectionRange positionMapping SelectionRange{..} = do - newRange <- toCurrentRange positionMapping _range - pure $ SelectionRange { - _range = newRange, +toCurrentSelectionRange positionMapping SelectionRange {..} = do + newRange <- toCurrentRange positionMapping _range + pure $ + SelectionRange + { _range = newRange, _parent = _parent >>= toCurrentSelectionRange positionMapping - } + } diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs index d44ed3debd..2df7b8b7f5 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -2,11 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange.ASTPreProcess - ( preProcessAST - , PreProcessEnv(..) - , isCustomNode - , CustomNodeType(..) - ) where + ( preProcessAST, + PreProcessEnv (..), + isCustomNode, + CustomNodeType (..), + ) +where import Control.Monad.Reader (Reader, asks) import Data.Foldable @@ -23,32 +24,29 @@ import qualified Data.Set as Set import Development.IDE.GHC.Compat hiding (nodeInfo) import Prelude hiding (span) -{-| -Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context --} +-- | +-- Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context newtype PreProcessEnv a = PreProcessEnv - { preProcessEnvRefMap :: RefMap a - } + { preProcessEnvRefMap :: RefMap a + } -{-| -Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies -the AST to handle some special cases. - -'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as -a concrete example example. - -Adding another manipulation to the AST is simple, just implement a function of type -`HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`. - -If it goes more complex, it may be more appropriate to split different manipulations to different modules. --} +-- | +-- Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies +-- the AST to handle some special cases. +-- +-- 'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as +-- a concrete example example. +-- +-- Adding another manipulation to the AST is simple, just implement a function of type +-- `HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`. +-- +-- If it goes more complex, it may be more appropriate to split different manipulations to different modules. preProcessAST :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition -{-| -Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST' -provided by GHC, but created to suite the needs of hls-code-range-plugin. --} +-- | +-- Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST' +-- provided by GHC, but created to suite the needs of hls-code-range-plugin. createCustomNode :: CustomNodeType -> NonEmpty (HieAST a) -> HieAST a createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEmpty.toList children) where @@ -59,25 +57,26 @@ createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEm isCustomNode :: HieAST a -> Maybe CustomNodeType isCustomNode node = do - nodeInfo <- generatedNodeInfo node - getFirst <$> foldMap go (nodeAnnotations nodeInfo) + nodeInfo <- generatedNodeInfo node + getFirst <$> foldMap go (nodeAnnotations nodeInfo) where go :: (FastStringCompat, FastStringCompat) -> Maybe (First CustomNodeType) go (k, v) - | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') - | otherwise = Nothing + | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') + | otherwise = Nothing -data CustomNodeType = - -- | a group of imports +data CustomNodeType + = -- | a group of imports CustomNodeImportsGroup - -- | adjacent type signature and value definition are paired under a custom parent node - | CustomNodeAdjacentSignatureDefinition - deriving (Show, Eq, Ord) + | -- | adjacent type signature and value definition are paired under a custom parent node + CustomNodeAdjacentSignatureDefinition + deriving (Show, Eq, Ord) customNodeTypeMapping :: Map CustomNodeType FastStringCompat -customNodeTypeMapping = Map.fromList - [ (CustomNodeImportsGroup, "Imports") - , (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") +customNodeTypeMapping = + Map.fromList + [ (CustomNodeImportsGroup, "Imports"), + (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") ] revCustomNodeTypeMapping :: Map FastStringCompat CustomNodeType @@ -86,44 +85,44 @@ revCustomNodeTypeMapping = Map.fromList . fmap (\(k, v) -> (v, k)) . Map.toList customNodeTypeToFastString :: CustomNodeType -> FastStringCompat customNodeTypeToFastString k = fromMaybe "" (customNodeTypeMapping Map.!? k) -{-| -Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting -the whole import area while expanding/shrinking the selection range. --} +-- | +-- Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting +-- the whole import area while expanding/shrinking the selection range. mergeImports :: forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a) -mergeImports node = pure $ node { nodeChildren = children } +mergeImports node = pure $ node {nodeChildren = children} where children :: [HieAST a] - children = mapMaybe merge + children = + mapMaybe merge . groupBy (\x y -> nodeIsImport x && nodeIsImport y) - . nodeChildren $ node + . nodeChildren + $ node merge :: [HieAST a] -> Maybe (HieAST a) - merge [] = Nothing - merge [x] = Just x - merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) + merge [] = Nothing + merge [x] = Just x + merge (x : xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) nodeIsImport :: HieAST a -> Bool nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") -{-| -Combine type signature with variable definition under a new parent node, if the signature is placed right before the -definition. This allows the user to have a step selecting both type signature and its accompanying definition. --} +-- | +-- Combine type signature with variable definition under a new parent node, if the signature is placed right before the +-- definition. This allows the user to have a step selecting both type signature and its accompanying definition. mergeSignatureWithDefinition :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) mergeSignatureWithDefinition node = do - refMap <- asks preProcessEnvRefMap - -- Do this recursively for children, so that non top level functions can be handled. - children' <- traverse mergeSignatureWithDefinition (nodeChildren node) - pure $ node { nodeChildren = reverse $ foldl' (go refMap) [] children' } + refMap <- asks preProcessEnvRefMap + -- Do this recursively for children, so that non top level functions can be handled. + children' <- traverse mergeSignatureWithDefinition (nodeChildren node) + pure $ node {nodeChildren = reverse $ foldl' (go refMap) [] children'} where -- For every two adjacent nodes, we try to combine them into one. go :: RefMap a -> [HieAST a] -> HieAST a -> [HieAST a] go _ [] node' = [node'] - go refMap (prev:others) node' = - case mergeAdjacentSigDef refMap (prev, node') of - Nothing -> node':prev:others - Just comb -> comb:others + go refMap (prev : others) node' = + case mergeAdjacentSigDef refMap (prev, node') of + Nothing -> node' : prev : others + Just comb -> comb : others -- | Merge adjacent type signature and variable/function definition, if the type signature belongs to that variable or -- function. @@ -131,47 +130,52 @@ mergeSignatureWithDefinition node = do -- The implementation potentially has some corner cases not handled properly. mergeAdjacentSigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a) mergeAdjacentSigDef refMap (n1, n2) = do - -- Let's check the node's annotation. There should be a function binding following its type signature. - checkAnnotation - -- Find the identifier of the type signature. - typeSigId <- identifierForTypeSig n1 - -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes. - refs <- Map.lookup typeSigId refMap - if any (isIdentADef (nodeSpan n2)) refs + -- Let's check the node's annotation. There should be a function binding following its type signature. + checkAnnotation + -- Find the identifier of the type signature. + typeSigId <- identifierForTypeSig n1 + -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes. + refs <- Map.lookup typeSigId refMap + if any (isIdentADef (nodeSpan n2)) refs then pure . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2] else Nothing where checkAnnotation :: Maybe () checkAnnotation = - if ("TypeSig", "Sig") `isAnnotationInAstNode` n1 && - (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2) - then Just () - else Nothing - -{-| -Given the AST node of a type signature, tries to find the identifier of it. --} + if ("TypeSig", "Sig") + `isAnnotationInAstNode` n1 + && (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2) + then Just () + else Nothing + +-- | +-- Given the AST node of a type signature, tries to find the identifier of it. identifierForTypeSig :: forall a. HieAST a -> Maybe Identifier identifierForTypeSig node = - {- - It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in - its children recursively. - -} - case mapMaybe extractIdentifier nodes of - [] -> Nothing - (ident:_) -> Just ident + {- + It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in + its children recursively. + -} + case mapMaybe extractIdentifier nodes of + [] -> Nothing + (ident : _) -> Just ident where nodes = flattenAst node extractIdentifier :: HieAST a -> Maybe Identifier - extractIdentifier node' = sourceNodeInfo node' >>= - (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) - . Map.toList . nodeIdentifiers) + extractIdentifier node' = + sourceNodeInfo node' + >>= ( 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 isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool isIdentADef outerSpan (span, detail) = - realSrcSpanStart span >= realSrcSpanStart outerSpan && realSrcSpanEnd span <= realSrcSpanEnd outerSpan + realSrcSpanStart span >= realSrcSpanStart outerSpan + && realSrcSpanEnd span <= realSrcSpanEnd outerSpan && isDef where isDef :: Bool @@ -179,9 +183,9 @@ isIdentADef outerSpan (span, detail) = -- Determines if the 'ContextInfo' represents a variable/function definition isContextInfoDef :: ContextInfo -> Bool - isContextInfoDef ValBind{} = True - isContextInfoDef MatchBind = True - isContextInfoDef _ = False + isContextInfoDef ValBind {} = True + isContextInfoDef MatchBind = True + isContextInfoDef _ = False isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index c52f796b72..f2efa51003 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -9,20 +9,21 @@ {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.CodeRange.Rules - ( CodeRange (..) - , codeRange_range - , codeRange_children - , codeRange_kind - , CodeRangeKind(..) - , GetCodeRange(..) - , codeRangeRule - , Log(..) + ( CodeRange (..), + codeRange_range, + codeRange_children, + codeRange_kind, + CodeRangeKind (..), + GetCodeRange (..), + codeRangeRule, + Log (..), -- * Internal - , removeInterleaving - , simplify - , crkToFrk - ) where + removeInterleaving, + simplify, + crkToFrk, + ) +where import Control.DeepSeq (NFData) import qualified Control.Lens as Lens @@ -55,72 +56,73 @@ 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) -import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) -data Log = LogShake Shake.Log - | LogNoAST - | LogFoundInterleaving CodeRange CodeRange - deriving Show +data Log + = LogShake Shake.Log + | LogNoAST + | LogFoundInterleaving CodeRange CodeRange + deriving (Show) instance Pretty Log where - pretty log = case log of - LogShake shakeLog -> pretty shakeLog - LogNoAST -> "no HieAst exist for file" - LogFoundInterleaving r1 r2 -> - let prettyRange = pretty . show . _codeRange_range - in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2 + pretty log = case log of + LogShake shakeLog -> pretty shakeLog + LogNoAST -> "no HieAst exist for file" + LogFoundInterleaving r1 r2 -> + let prettyRange = pretty . show . _codeRange_range + in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2 -- | A tree representing code ranges in a file. This can be useful for features like selection range and folding range -data CodeRange = CodeRange { - -- | Range for current level - _codeRange_range :: !Range, +data CodeRange = CodeRange + { -- | Range for current level + _codeRange_range :: !Range, -- | A vector of children, sorted by their ranges in ascending order. -- Children are guaranteed not to interleave, but some gaps may exist among them. - _codeRange_children :: !(Vector CodeRange), + _codeRange_children :: !(Vector CodeRange), -- The kind of current code range - _codeRange_kind :: !CodeRangeKind - } - deriving (Show, Generic, NFData) + _codeRange_kind :: !CodeRangeKind + } + deriving (Show, Generic, NFData) -- | 'CodeKind' represents the kind of a code range -data CodeRangeKind = - -- | ordinary code +data CodeRangeKind + = -- | ordinary code CodeKindRegion - -- | the group of imports - | CodeKindImports - -- | a comment - | CodeKindComment - deriving (Show, Eq, Generic, NFData) + | -- | the group of imports + CodeKindImports + | -- | a comment + CodeKindComment + deriving (Show, Eq, Generic, NFData) Lens.makeLenses ''CodeRange instance Eq CodeRange where - (==) = (==) `on` _codeRange_range + (==) = (==) `on` _codeRange_range instance Ord CodeRange where - compare :: CodeRange -> CodeRange -> Ordering - compare = compare `on` _codeRange_range + compare :: CodeRange -> CodeRange -> Ordering + compare = compare `on` _codeRange_range -- | Construct a 'CodeRange'. A valid CodeRange will be returned in any case. If anything go wrong, -- a list of warnings will be returned as 'Log' buildCodeRange :: HieAST a -> RefMap a -> Annotated ParsedSource -> Writer [Log] CodeRange buildCodeRange ast refMap _ = do - -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding - -- range don't need to care about 'HieAST' - -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments) - let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) - codeRange <- astToCodeRange ast' - pure $ simplify codeRange + -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding + -- range don't need to care about 'HieAST' + -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments) + let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) + codeRange <- astToCodeRange ast' + pure $ simplify codeRange astToCodeRange :: HieAST a -> Writer [Log] CodeRange astToCodeRange (Node _ sp []) = pure $ CodeRange (realSrcSpanToRange sp) mempty CodeKindRegion astToCodeRange node@(Node _ sp children) = do - children' <- removeInterleaving . sort =<< traverse astToCodeRange children - let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion - pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind + children' <- removeInterleaving . sort =<< traverse astToCodeRange children + let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion + pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind -- | Remove interleaving of the list of 'CodeRange's. removeInterleaving :: [CodeRange] -> Writer [Log] [CodeRange] @@ -129,77 +131,80 @@ removeInterleaving = fmap reverse . foldM go [] -- we want to traverse from left to right (to make the logs easier to read) go :: [CodeRange] -> CodeRange -> Writer [Log] [CodeRange] go [] x = pure [x] - go (x1:acc) x2 = do - -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range - -- compares it's start position first, the start position must be already in an ascending order. - -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving - -- must exist. - -- (Note: LSP Range's end position is exclusive) - x1' <- if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start - then do - -- set x1.end to x2.start - let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start) - tell [LogFoundInterleaving x1 x2] - pure x1' - else pure x1 - pure $ x2:x1':acc + go (x1 : acc) x2 = do + -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range + -- compares it's start position first, the start position must be already in an ascending order. + -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving + -- must exist. + -- (Note: LSP Range's end position is exclusive) + x1' <- + if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start + then do + -- set x1.end to x2.start + let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start) + tell [LogFoundInterleaving x1 x2] + pure x1' + else pure x1 + pure $ x2 : x1' : acc -- | Remove redundant nodes in 'CodeRange' tree simplify :: CodeRange -> CodeRange simplify r = - case onlyChild of - -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed. - Just onlyChild' -> - if _codeRange_range onlyChild' == curRange - then simplify (r { _codeRange_children = _codeRange_children onlyChild' }) - else withChildrenSimplified - Nothing -> withChildrenSimplified + case onlyChild of + -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed. + Just onlyChild' -> + if _codeRange_range onlyChild' == curRange + then simplify (r {_codeRange_children = _codeRange_children onlyChild'}) + else withChildrenSimplified + Nothing -> withChildrenSimplified where curRange = _codeRange_range r onlyChild :: Maybe CodeRange = - let children = _codeRange_children r - in if V.length children == 1 then V.headM children else Nothing + let children = _codeRange_children r + in if V.length children == 1 then V.headM children else Nothing - withChildrenSimplified = r { _codeRange_children = simplify <$> _codeRange_children r } + withChildrenSimplified = r {_codeRange_children = simplify <$> _codeRange_children r} data GetCodeRange = GetCodeRange - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Typeable, Generic) instance Hashable GetCodeRange -instance NFData GetCodeRange + +instance NFData GetCodeRange type instance RuleResult GetCodeRange = CodeRange codeRangeRule :: Recorder (WithPriority Log) -> Rules () codeRangeRule recorder = - define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do - -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). - -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations - HAR{hieAst, refMap} <- lift $ use_ GetHieAst file - ast <- maybeToExceptT LogNoAST . MaybeT . pure $ - getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file - annPS <- lift $ use_ GetAnnotatedParsedSource file + define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do + -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). + -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations + HAR {hieAst, refMap} <- lift $ use_ GetHieAst file + ast <- + maybeToExceptT LogNoAST . MaybeT . pure $ + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file + annPS <- lift $ use_ GetAnnotatedParsedSource file - let (codeRange, warnings) = runWriter (buildCodeRange ast refMap annPS) - traverse_ (logWith recorder Warning) warnings + let (codeRange, warnings) = runWriter (buildCodeRange ast refMap annPS) + traverse_ (logWith recorder Warning) warnings - pure codeRange + pure codeRange -- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log) handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a) handleError recorder action' = do - valueEither <- runExceptT action' - case valueEither of - Left msg -> do - logWith recorder Error msg - pure $ toIdeResult (Left []) - Right value -> pure $ toIdeResult (Right value) + valueEither <- runExceptT action' + case valueEither of + Left msg -> do + logWith recorder Error msg + pure $ toIdeResult (Left []) + Right value -> pure $ toIdeResult (Right value) -- | Maps type CodeRangeKind to FoldingRangeKind crkToFrk :: CodeRangeKind -> Maybe FoldingRangeKind crkToFrk crk = case crk of - CodeKindComment -> Just FoldingRangeComment - CodeKindImports -> Just FoldingRangeImports - CodeKindRegion -> Just FoldingRangeRegion - _ -> Nothing \ No newline at end of file + CodeKindComment -> Just FoldingRangeComment + CodeKindImports -> Just FoldingRangeImports + CodeKindRegion -> Just FoldingRangeRegion + _ -> Nothing diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs index ca7b0cca9b..8ff948ba77 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs @@ -15,8 +15,8 @@ import Language.LSP.Server (MonadLsp) -- | The Eval plugin configuration. (see 'properties') data EvalConfig = EvalConfig - { eval_cfg_diff :: Bool - , eval_cfg_exception :: Bool + { eval_cfg_diff :: Bool + , eval_cfg_exception :: Bool } deriving (Eq, Ord, Show) From e21f5cb3a10e72e3c9b6eb5ad3a660d8249da020 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sat, 13 Aug 2022 02:34:15 +0530 Subject: [PATCH 11/31] fix: return all response results of folding range request --- hls-plugin-api/src/Ide/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 1a42892a8c..bf78fcab81 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -17,7 +18,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} module Ide.Types where @@ -31,10 +31,10 @@ import System.Posix.Signals #endif import Control.Lens ((^.)) import Data.Aeson hiding (defaultOptions) -import qualified Data.DList as DList import qualified Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap +import qualified Data.DList as DList import Data.GADT.Compare import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map @@ -478,7 +478,7 @@ instance PluginRequestMethod TextDocumentSelectionRange where combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod TextDocumentFoldingRange where - combineResponses _ _ _ _ (x :| _) = x + combineResponses _ _ _ _ x = sconcat x instance PluginRequestMethod CallHierarchyIncomingCalls where From 799db9bf74ddb058d9f6b5dbf5e2a3e6462c2305 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sat, 13 Aug 2022 09:47:32 +0530 Subject: [PATCH 12/31] Revert "format: run formatter and add comments" This reverts commit e6a2b5ca3e8232bc082ce84d22545a5bd462a2ff. --- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 165 +++++++-------- .../src/Ide/Plugin/CodeRange/ASTPreProcess.hs | 182 ++++++++-------- .../src/Ide/Plugin/CodeRange/Rules.hs | 195 +++++++++--------- .../src/Ide/Plugin/Eval/Config.hs | 4 +- 5 files changed, 264 insertions(+), 284 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 13f33278a8..e7cbb5ccdb 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -110,7 +110,7 @@ data PluginConfig = , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool - , plcFoldingRangeOn :: !Bool + , plcFoldingRangeOn :: !Bool , plcConfig :: !A.Object } deriving (Show,Eq) 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 3e2512658c..ca20e1c01f 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ide.Plugin.CodeRange - ( descriptor, - Log, +module Ide.Plugin.CodeRange ( + descriptor + , Log -- * Internal - findPosition, - ) -where + , findPosition + ) where import Control.Monad.Except (ExceptT (ExceptT), runExceptT) @@ -17,7 +16,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) -import Data.Maybe (fromMaybe) +import Data.Maybe ( fromMaybe, catMaybes ) import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE (IdeAction, @@ -44,67 +43,62 @@ import Ide.Types (PluginDescriptor (pluginH defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Server (LspM) -import Language.LSP.Types (FoldingRange (..), - FoldingRangeParams (..), - List (List), +import Language.LSP.Types (List (List), NormalizedFilePath, Position (..), Range (_start), ResponseError, - SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), + SMethod (STextDocumentSelectionRange, STextDocumentFoldingRange), SelectionRange (..), SelectionRangeParams (..), + FoldingRange (..), + FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri) + Uri + ) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = - (defaultPluginDescriptor plId) - { pluginHandlers = - mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler, - pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler + <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler + , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) } data Log = LogRules Rules.Log instance Pretty Log where - pretty log = case log of - LogRules codeRangeLog -> pretty codeRangeLog + pretty log = case log of + LogRules codeRangeLog -> pretty codeRangeLog foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) -foldingRangeHandler ide _ FoldingRangeParams {..} = do - pluginResponse $ do - filePath <- - ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - foldingRanges <- - ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ - getFoldingRanges filePath - pure . List $ foldingRanges - where - uri :: Uri - TextDocumentIdentifier uri = _textDocument +foldingRangeHandler ide _ FoldingRangeParams{..} = do + pluginResponse $ do + filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ + getFoldingRanges filePath + pure . List $ foldingRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] getFoldingRanges file = do - (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file + (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - let foldingRanges = findFoldingRanges codeRange + let foldingRanges = findFoldingRanges codeRange - maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) + maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) -selectionRangeHandler ide _ SelectionRangeParams {..} = 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 +selectionRangeHandler ide _ SelectionRangeParams{..} = 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 where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -114,20 +108,19 @@ selectionRangeHandler ide _ SelectionRangeParams {..} = do getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String 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 $ - traverse (fromCurrentPosition positionMapping) positions + (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 $ + 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. - let defaultSelectionRange = SelectionRange (Range pos pos) Nothing - in fromMaybe defaultSelectionRange . findPosition pos $ codeRange + 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. + 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 $ - traverse (toCurrentSelectionRange positionMapping) selectionRanges + -- 'positionMapping' should be applied to the output ranges before returning them + maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + 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 @@ -136,11 +129,11 @@ findPosition pos root = go Nothing root -- Helper function for recursion. The range list is built top-down go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange go acc node = - if positionInRange pos range + if positionInRange pos range then maybe acc' (go acc') (binarySearchPos children) - else -- If all children doesn't contain pos, acc' will be returned. + -- If all children doesn't contain pos, acc' will be returned. -- acc' will be Nothing only if we are in the root level. - Nothing + else Nothing where range = _codeRange_range node children = _codeRange_children node @@ -148,46 +141,42 @@ findPosition pos root = go Nothing root binarySearchPos :: Vector CodeRange -> Maybe CodeRange binarySearchPos v - | V.null v = Nothing - | V.length v == 1, - Just r <- V.headM v = - if positionInRange pos (_codeRange_range r) then Just r else Nothing - | otherwise = do - 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 children to a folding ranges + | V.null v = Nothing + | V.length v == 1, + Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing + | otherwise = do + 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 + findFoldingRanges :: CodeRange -> [FoldingRange] findFoldingRanges r@(CodeRange _ children _) = let frRoot :: [FoldingRange] = case createFoldingRange r of - Just x -> [x] + Just x -> [x] Nothing -> [] frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children in frRoot ++ frChildren --- | Parses code range to folding range createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange node1 = do - let range = _codeRange_range node1 - let Range startPos endPos = range - let Position lineStart _ = startPos - let Position lineEnd _ = endPos - let codeRangeKind = _codeRange_kind node1 + let range = _codeRange_range node1 + let Range startPos endPos = range + let Position lineStart _= startPos + let Position lineEnd _ = endPos + let codeRangeKind = _codeRange_kind node1 - let frk = crkToFrk codeRangeKind + let frk = crkToFrk codeRangeKind - case frk of - Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) - Nothing -> Nothing + case frk of + Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) + Nothing -> Nothing -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange -toCurrentSelectionRange positionMapping SelectionRange {..} = do - newRange <- toCurrentRange positionMapping _range - pure $ - SelectionRange - { _range = newRange, +toCurrentSelectionRange positionMapping SelectionRange{..} = do + newRange <- toCurrentRange positionMapping _range + pure $ SelectionRange { + _range = newRange, _parent = _parent >>= toCurrentSelectionRange positionMapping - } + } diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs index 2df7b8b7f5..d44ed3debd 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -2,12 +2,11 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange.ASTPreProcess - ( preProcessAST, - PreProcessEnv (..), - isCustomNode, - CustomNodeType (..), - ) -where + ( preProcessAST + , PreProcessEnv(..) + , isCustomNode + , CustomNodeType(..) + ) where import Control.Monad.Reader (Reader, asks) import Data.Foldable @@ -24,29 +23,32 @@ import qualified Data.Set as Set import Development.IDE.GHC.Compat hiding (nodeInfo) import Prelude hiding (span) --- | --- Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context +{-| +Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context +-} newtype PreProcessEnv a = PreProcessEnv - { preProcessEnvRefMap :: RefMap a - } + { preProcessEnvRefMap :: RefMap a + } --- | --- Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies --- the AST to handle some special cases. --- --- 'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as --- a concrete example example. --- --- Adding another manipulation to the AST is simple, just implement a function of type --- `HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`. --- --- If it goes more complex, it may be more appropriate to split different manipulations to different modules. +{-| +Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies +the AST to handle some special cases. + +'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as +a concrete example example. + +Adding another manipulation to the AST is simple, just implement a function of type +`HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`. + +If it goes more complex, it may be more appropriate to split different manipulations to different modules. +-} preProcessAST :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition --- | --- Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST' --- provided by GHC, but created to suite the needs of hls-code-range-plugin. +{-| +Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST' +provided by GHC, but created to suite the needs of hls-code-range-plugin. +-} createCustomNode :: CustomNodeType -> NonEmpty (HieAST a) -> HieAST a createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEmpty.toList children) where @@ -57,26 +59,25 @@ createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEm isCustomNode :: HieAST a -> Maybe CustomNodeType isCustomNode node = do - nodeInfo <- generatedNodeInfo node - getFirst <$> foldMap go (nodeAnnotations nodeInfo) + nodeInfo <- generatedNodeInfo node + getFirst <$> foldMap go (nodeAnnotations nodeInfo) where go :: (FastStringCompat, FastStringCompat) -> Maybe (First CustomNodeType) go (k, v) - | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') - | otherwise = Nothing + | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') + | otherwise = Nothing -data CustomNodeType - = -- | a group of imports +data CustomNodeType = + -- | a group of imports CustomNodeImportsGroup - | -- | adjacent type signature and value definition are paired under a custom parent node - CustomNodeAdjacentSignatureDefinition - deriving (Show, Eq, Ord) + -- | adjacent type signature and value definition are paired under a custom parent node + | CustomNodeAdjacentSignatureDefinition + deriving (Show, Eq, Ord) customNodeTypeMapping :: Map CustomNodeType FastStringCompat -customNodeTypeMapping = - Map.fromList - [ (CustomNodeImportsGroup, "Imports"), - (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") +customNodeTypeMapping = Map.fromList + [ (CustomNodeImportsGroup, "Imports") + , (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") ] revCustomNodeTypeMapping :: Map FastStringCompat CustomNodeType @@ -85,44 +86,44 @@ revCustomNodeTypeMapping = Map.fromList . fmap (\(k, v) -> (v, k)) . Map.toList customNodeTypeToFastString :: CustomNodeType -> FastStringCompat customNodeTypeToFastString k = fromMaybe "" (customNodeTypeMapping Map.!? k) --- | --- Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting --- the whole import area while expanding/shrinking the selection range. +{-| +Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting +the whole import area while expanding/shrinking the selection range. +-} mergeImports :: forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a) -mergeImports node = pure $ node {nodeChildren = children} +mergeImports node = pure $ node { nodeChildren = children } where children :: [HieAST a] - children = - mapMaybe merge + children = mapMaybe merge . groupBy (\x y -> nodeIsImport x && nodeIsImport y) - . nodeChildren - $ node + . nodeChildren $ node merge :: [HieAST a] -> Maybe (HieAST a) - merge [] = Nothing - merge [x] = Just x - merge (x : xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) + merge [] = Nothing + merge [x] = Just x + merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) nodeIsImport :: HieAST a -> Bool nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") --- | --- Combine type signature with variable definition under a new parent node, if the signature is placed right before the --- definition. This allows the user to have a step selecting both type signature and its accompanying definition. +{-| +Combine type signature with variable definition under a new parent node, if the signature is placed right before the +definition. This allows the user to have a step selecting both type signature and its accompanying definition. +-} mergeSignatureWithDefinition :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) mergeSignatureWithDefinition node = do - refMap <- asks preProcessEnvRefMap - -- Do this recursively for children, so that non top level functions can be handled. - children' <- traverse mergeSignatureWithDefinition (nodeChildren node) - pure $ node {nodeChildren = reverse $ foldl' (go refMap) [] children'} + refMap <- asks preProcessEnvRefMap + -- Do this recursively for children, so that non top level functions can be handled. + children' <- traverse mergeSignatureWithDefinition (nodeChildren node) + pure $ node { nodeChildren = reverse $ foldl' (go refMap) [] children' } where -- For every two adjacent nodes, we try to combine them into one. go :: RefMap a -> [HieAST a] -> HieAST a -> [HieAST a] go _ [] node' = [node'] - go refMap (prev : others) node' = - case mergeAdjacentSigDef refMap (prev, node') of - Nothing -> node' : prev : others - Just comb -> comb : others + go refMap (prev:others) node' = + case mergeAdjacentSigDef refMap (prev, node') of + Nothing -> node':prev:others + Just comb -> comb:others -- | Merge adjacent type signature and variable/function definition, if the type signature belongs to that variable or -- function. @@ -130,52 +131,47 @@ mergeSignatureWithDefinition node = do -- The implementation potentially has some corner cases not handled properly. mergeAdjacentSigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a) mergeAdjacentSigDef refMap (n1, n2) = do - -- Let's check the node's annotation. There should be a function binding following its type signature. - checkAnnotation - -- Find the identifier of the type signature. - typeSigId <- identifierForTypeSig n1 - -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes. - refs <- Map.lookup typeSigId refMap - if any (isIdentADef (nodeSpan n2)) refs + -- Let's check the node's annotation. There should be a function binding following its type signature. + checkAnnotation + -- Find the identifier of the type signature. + typeSigId <- identifierForTypeSig n1 + -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes. + refs <- Map.lookup typeSigId refMap + if any (isIdentADef (nodeSpan n2)) refs then pure . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2] else Nothing where checkAnnotation :: Maybe () checkAnnotation = - if ("TypeSig", "Sig") - `isAnnotationInAstNode` n1 - && (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2) - then Just () - else Nothing - --- | --- Given the AST node of a type signature, tries to find the identifier of it. + if ("TypeSig", "Sig") `isAnnotationInAstNode` n1 && + (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2) + then Just () + else Nothing + +{-| +Given the AST node of a type signature, tries to find the identifier of it. +-} identifierForTypeSig :: forall a. HieAST a -> Maybe Identifier identifierForTypeSig node = - {- - It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in - its children recursively. - -} - case mapMaybe extractIdentifier nodes of - [] -> Nothing - (ident : _) -> Just ident + {- + It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in + its children recursively. + -} + case mapMaybe extractIdentifier nodes of + [] -> Nothing + (ident:_) -> Just ident where nodes = flattenAst node extractIdentifier :: HieAST a -> Maybe Identifier - extractIdentifier node' = - sourceNodeInfo node' - >>= ( fmap fst - . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) - . Map.toList - . nodeIdentifiers - ) + extractIdentifier node' = sourceNodeInfo node' >>= + (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 isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool isIdentADef outerSpan (span, detail) = - realSrcSpanStart span >= realSrcSpanStart outerSpan - && realSrcSpanEnd span <= realSrcSpanEnd outerSpan + realSrcSpanStart span >= realSrcSpanStart outerSpan && realSrcSpanEnd span <= realSrcSpanEnd outerSpan && isDef where isDef :: Bool @@ -183,9 +179,9 @@ isIdentADef outerSpan (span, detail) = -- Determines if the 'ContextInfo' represents a variable/function definition isContextInfoDef :: ContextInfo -> Bool - isContextInfoDef ValBind {} = True - isContextInfoDef MatchBind = True - isContextInfoDef _ = False + isContextInfoDef ValBind{} = True + isContextInfoDef MatchBind = True + isContextInfoDef _ = False isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index f2efa51003..c52f796b72 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -9,21 +9,20 @@ {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.CodeRange.Rules - ( CodeRange (..), - codeRange_range, - codeRange_children, - codeRange_kind, - CodeRangeKind (..), - GetCodeRange (..), - codeRangeRule, - Log (..), + ( CodeRange (..) + , codeRange_range + , codeRange_children + , codeRange_kind + , CodeRangeKind(..) + , GetCodeRange(..) + , codeRangeRule + , Log(..) -- * Internal - removeInterleaving, - simplify, - crkToFrk, - ) -where + , removeInterleaving + , simplify + , crkToFrk + ) where import Control.DeepSeq (NFData) import qualified Control.Lens as Lens @@ -56,73 +55,72 @@ 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) +import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) -data Log - = LogShake Shake.Log - | LogNoAST - | LogFoundInterleaving CodeRange CodeRange - deriving (Show) +data Log = LogShake Shake.Log + | LogNoAST + | LogFoundInterleaving CodeRange CodeRange + deriving Show instance Pretty Log where - pretty log = case log of - LogShake shakeLog -> pretty shakeLog - LogNoAST -> "no HieAst exist for file" - LogFoundInterleaving r1 r2 -> - let prettyRange = pretty . show . _codeRange_range - in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2 + pretty log = case log of + LogShake shakeLog -> pretty shakeLog + LogNoAST -> "no HieAst exist for file" + LogFoundInterleaving r1 r2 -> + let prettyRange = pretty . show . _codeRange_range + in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2 -- | A tree representing code ranges in a file. This can be useful for features like selection range and folding range -data CodeRange = CodeRange - { -- | Range for current level - _codeRange_range :: !Range, +data CodeRange = CodeRange { + -- | Range for current level + _codeRange_range :: !Range, -- | A vector of children, sorted by their ranges in ascending order. -- Children are guaranteed not to interleave, but some gaps may exist among them. - _codeRange_children :: !(Vector CodeRange), + _codeRange_children :: !(Vector CodeRange), -- The kind of current code range - _codeRange_kind :: !CodeRangeKind - } - deriving (Show, Generic, NFData) + _codeRange_kind :: !CodeRangeKind + } + deriving (Show, Generic, NFData) -- | 'CodeKind' represents the kind of a code range -data CodeRangeKind - = -- | ordinary code +data CodeRangeKind = + -- | ordinary code CodeKindRegion - | -- | the group of imports - CodeKindImports - | -- | a comment - CodeKindComment - deriving (Show, Eq, Generic, NFData) + -- | the group of imports + | CodeKindImports + -- | a comment + | CodeKindComment + deriving (Show, Eq, Generic, NFData) Lens.makeLenses ''CodeRange instance Eq CodeRange where - (==) = (==) `on` _codeRange_range + (==) = (==) `on` _codeRange_range instance Ord CodeRange where - compare :: CodeRange -> CodeRange -> Ordering - compare = compare `on` _codeRange_range + compare :: CodeRange -> CodeRange -> Ordering + compare = compare `on` _codeRange_range -- | Construct a 'CodeRange'. A valid CodeRange will be returned in any case. If anything go wrong, -- a list of warnings will be returned as 'Log' buildCodeRange :: HieAST a -> RefMap a -> Annotated ParsedSource -> Writer [Log] CodeRange buildCodeRange ast refMap _ = do - -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding - -- range don't need to care about 'HieAST' - -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments) - let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) - codeRange <- astToCodeRange ast' - pure $ simplify codeRange + -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding + -- range don't need to care about 'HieAST' + -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments) + let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) + codeRange <- astToCodeRange ast' + pure $ simplify codeRange astToCodeRange :: HieAST a -> Writer [Log] CodeRange astToCodeRange (Node _ sp []) = pure $ CodeRange (realSrcSpanToRange sp) mempty CodeKindRegion astToCodeRange node@(Node _ sp children) = do - children' <- removeInterleaving . sort =<< traverse astToCodeRange children - let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion - pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind + children' <- removeInterleaving . sort =<< traverse astToCodeRange children + let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion + pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind -- | Remove interleaving of the list of 'CodeRange's. removeInterleaving :: [CodeRange] -> Writer [Log] [CodeRange] @@ -131,80 +129,77 @@ removeInterleaving = fmap reverse . foldM go [] -- we want to traverse from left to right (to make the logs easier to read) go :: [CodeRange] -> CodeRange -> Writer [Log] [CodeRange] go [] x = pure [x] - go (x1 : acc) x2 = do - -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range - -- compares it's start position first, the start position must be already in an ascending order. - -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving - -- must exist. - -- (Note: LSP Range's end position is exclusive) - x1' <- - if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start - then do - -- set x1.end to x2.start - let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start) - tell [LogFoundInterleaving x1 x2] - pure x1' - else pure x1 - pure $ x2 : x1' : acc + go (x1:acc) x2 = do + -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range + -- compares it's start position first, the start position must be already in an ascending order. + -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving + -- must exist. + -- (Note: LSP Range's end position is exclusive) + x1' <- if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start + then do + -- set x1.end to x2.start + let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start) + tell [LogFoundInterleaving x1 x2] + pure x1' + else pure x1 + pure $ x2:x1':acc -- | Remove redundant nodes in 'CodeRange' tree simplify :: CodeRange -> CodeRange simplify r = - case onlyChild of - -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed. - Just onlyChild' -> - if _codeRange_range onlyChild' == curRange - then simplify (r {_codeRange_children = _codeRange_children onlyChild'}) - else withChildrenSimplified - Nothing -> withChildrenSimplified + case onlyChild of + -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed. + Just onlyChild' -> + if _codeRange_range onlyChild' == curRange + then simplify (r { _codeRange_children = _codeRange_children onlyChild' }) + else withChildrenSimplified + Nothing -> withChildrenSimplified where curRange = _codeRange_range r onlyChild :: Maybe CodeRange = - let children = _codeRange_children r - in if V.length children == 1 then V.headM children else Nothing + let children = _codeRange_children r + in if V.length children == 1 then V.headM children else Nothing - withChildrenSimplified = r {_codeRange_children = simplify <$> _codeRange_children r} + withChildrenSimplified = r { _codeRange_children = simplify <$> _codeRange_children r } data GetCodeRange = GetCodeRange - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Typeable, Generic) instance Hashable GetCodeRange - -instance NFData GetCodeRange +instance NFData GetCodeRange type instance RuleResult GetCodeRange = CodeRange codeRangeRule :: Recorder (WithPriority Log) -> Rules () codeRangeRule recorder = - define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do - -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). - -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations - HAR {hieAst, refMap} <- lift $ use_ GetHieAst file - ast <- - maybeToExceptT LogNoAST . MaybeT . pure $ - getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file - annPS <- lift $ use_ GetAnnotatedParsedSource file + define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do + -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). + -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations + HAR{hieAst, refMap} <- lift $ use_ GetHieAst file + ast <- maybeToExceptT LogNoAST . MaybeT . pure $ + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file + annPS <- lift $ use_ GetAnnotatedParsedSource file - let (codeRange, warnings) = runWriter (buildCodeRange ast refMap annPS) - traverse_ (logWith recorder Warning) warnings + let (codeRange, warnings) = runWriter (buildCodeRange ast refMap annPS) + traverse_ (logWith recorder Warning) warnings - pure codeRange + pure codeRange -- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log) handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a) handleError recorder action' = do - valueEither <- runExceptT action' - case valueEither of - Left msg -> do - logWith recorder Error msg - pure $ toIdeResult (Left []) - Right value -> pure $ toIdeResult (Right value) + valueEither <- runExceptT action' + case valueEither of + Left msg -> do + logWith recorder Error msg + pure $ toIdeResult (Left []) + Right value -> pure $ toIdeResult (Right value) -- | Maps type CodeRangeKind to FoldingRangeKind crkToFrk :: CodeRangeKind -> Maybe FoldingRangeKind crkToFrk crk = case crk of - CodeKindComment -> Just FoldingRangeComment - CodeKindImports -> Just FoldingRangeImports - CodeKindRegion -> Just FoldingRangeRegion - _ -> Nothing + CodeKindComment -> Just FoldingRangeComment + CodeKindImports -> Just FoldingRangeImports + CodeKindRegion -> Just FoldingRangeRegion + _ -> Nothing \ No newline at end of file diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs index 8ff948ba77..ca7b0cca9b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs @@ -15,8 +15,8 @@ import Language.LSP.Server (MonadLsp) -- | The Eval plugin configuration. (see 'properties') data EvalConfig = EvalConfig - { eval_cfg_diff :: Bool - , eval_cfg_exception :: Bool + { eval_cfg_diff :: Bool + , eval_cfg_exception :: Bool } deriving (Eq, Ord, Show) From 5d0d15965e8067b2c34c743afeb2ba4f97c544b3 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sat, 13 Aug 2022 09:53:16 +0530 Subject: [PATCH 13/31] add: removed comments after revert --- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs | 2 ++ 1 file changed, 2 insertions(+) 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 ca20e1c01f..f4864be70f 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -149,6 +149,7 @@ findPosition pos root = go Nothing root startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right +-- | Traverses through the code range and children to a folding ranges findFoldingRanges :: CodeRange -> [FoldingRange] findFoldingRanges r@(CodeRange _ children _) = let frRoot :: [FoldingRange] = case createFoldingRange r of @@ -158,6 +159,7 @@ findFoldingRanges r@(CodeRange _ children _) = frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children in frRoot ++ frChildren +-- | Parses code range to folding range createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange node1 = do let range = _codeRange_range node1 From 332e9538790ef4b4eb1a6dad5c55216405d7ec62 Mon Sep 17 00:00:00 2001 From: sloorush Date: Tue, 16 Aug 2022 14:48:16 +0530 Subject: [PATCH 14/31] fix: formatting --- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 21 +++++++++---------- .../src/Ide/Plugin/CodeRange/Rules.hs | 6 +++--- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index e7cbb5ccdb..13f33278a8 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -110,7 +110,7 @@ data PluginConfig = , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool - , plcFoldingRangeOn :: !Bool + , plcFoldingRangeOn :: !Bool , plcConfig :: !A.Object } deriving (Show,Eq) 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 f4864be70f..062ad5bbb8 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange ( @@ -16,7 +16,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) -import Data.Maybe ( fromMaybe, catMaybes ) +import Data.Maybe (catMaybes, fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE (IdeAction, @@ -43,19 +43,18 @@ import Ide.Types (PluginDescriptor (pluginH defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Server (LspM) -import Language.LSP.Types (List (List), +import Language.LSP.Types (FoldingRange (..), + FoldingRangeParams (..), + List (List), NormalizedFilePath, Position (..), Range (_start), ResponseError, - SMethod (STextDocumentSelectionRange, STextDocumentFoldingRange), + SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), - FoldingRange (..), - FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri - ) + Uri) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -153,7 +152,7 @@ findPosition pos root = go Nothing root findFoldingRanges :: CodeRange -> [FoldingRange] findFoldingRanges r@(CodeRange _ children _) = let frRoot :: [FoldingRange] = case createFoldingRange r of - Just x -> [x] + Just x -> [x] Nothing -> [] frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children @@ -171,7 +170,7 @@ createFoldingRange node1 = do let frk = crkToFrk codeRangeKind case frk of - Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) + Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) Nothing -> Nothing -- | Likes 'toCurrentPosition', but works on 'SelectionRange' diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index c52f796b72..a8fa5223aa 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -55,10 +55,10 @@ 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) -import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) data Log = LogShake Shake.Log | LogNoAST @@ -201,5 +201,5 @@ crkToFrk :: CodeRangeKind -> Maybe FoldingRangeKind crkToFrk crk = case crk of CodeKindComment -> Just FoldingRangeComment CodeKindImports -> Just FoldingRangeImports - CodeKindRegion -> Just FoldingRangeRegion - _ -> Nothing \ No newline at end of file + CodeKindRegion -> Just FoldingRangeRegion + _ -> Nothing From c4f386d457aee4941787d89df8373c835826ead1 Mon Sep 17 00:00:00 2001 From: sloorush Date: Tue, 16 Aug 2022 15:12:47 +0530 Subject: [PATCH 15/31] docs: add folding range to features section and cabal file --- docs/features.md | 39 ++++++++++++------- .../hls-code-range-plugin.cabal | 2 +- 2 files changed, 26 insertions(+), 15 deletions(-) diff --git a/docs/features.md b/docs/features.md index 58fa945299..7aa31d2d3c 100644 --- a/docs/features.md +++ b/docs/features.md @@ -4,7 +4,7 @@ This table gives a summary of the features that HLS supports. Many of these are standard LSP features, but a lot of special features are provided as [code actions](#code-actions) and [code lenses](#code-lenses). | Feature | [LSP method](./what-is-hls.md#lsp-terminology) | -|-----------------------------------------------------|---------------------------------------------------------------------------------------------------| +| --------------------------------------------------- | ------------------------------------------------------------------------------------------------- | | [Diagnostics](#diagnostics) | `textDocument/publishDiagnostics` | | [Hovers](#hovers) | `textDocument/hover` | | [Jump to definition](#jump-to-definition) | `textDocument/definition` | @@ -88,7 +88,7 @@ Completions for language pragmas. Format your code with various Haskell code formatters. | Formatter | Provided by | -|-----------------|------------------------------| +| --------------- | ---------------------------- | | Brittany | `hls-brittany-plugin` | | Floskell | `hls-floskell-plugin` | | Fourmolu | `hls-fourmolu-plugin` | @@ -249,6 +249,7 @@ Change/Update a type signature to match implementation. Status: Until GHC 9.4, the implementation is ad-hoc and relies on GHC error messages to create a new signature. Not all GHC error messages are supported. Known Limitations: + - Not all GHC error messages are supported - Top-level and Function-local bindings with the same names can cause issues, such as incorrect signature changes or no code actions available. @@ -325,6 +326,16 @@ support. ![Selection range demo](https://user-images.githubusercontent.com/16440269/177240833-7dc8fe39-b446-477e-b5b1-7fc303608d4f.gif) +## Folding range + +Provided by: `hls-code-range-plugin` + +Provides haskell specific +[Folding](https://code.visualstudio.com/docs/editor/codebasics#_folding) +support. + +![Folding range demo](https://user-images.githubusercontent.com/54478821/184468510-7c0d5182-c684-48ef-9b39-3866dc2309df.gif) + ## Rename Provided by: `hls-rename-plugin` @@ -342,15 +353,15 @@ Known limitations: The following features are supported by the LSP specification but not implemented in HLS. Contributions welcome! -| Feature | Status | [LSP method](./what-is-hls.md#lsp-terminology) | -|------------------------|------------------------------------------------------------------------------------------|-----------------------------------------------------| -| Signature help | Unimplemented | `textDocument/signatureHelp` | -| Jump to declaration | Unclear if useful | `textDocument/declaration` | -| Jump to implementation | Unclear if useful | `textDocument/implementation` | -| Folding | Unimplemented | `textDocument/foldingRange` | -| Semantic tokens | Unimplemented | `textDocument/semanticTokens` | -| Linked editing | Unimplemented | `textDocument/linkedEditingRange` | -| Document links | Unimplemented | `textDocument/documentLink` | -| Document color | Unclear if useful | `textDocument/documentColor` | -| Color presentation | Unclear if useful | `textDocument/colorPresentation` | -| Monikers | Unclear if useful | `textDocument/moniker` | +| Feature | Status | [LSP method](./what-is-hls.md#lsp-terminology) | +| ---------------------- | ----------------- | ---------------------------------------------- | +| Signature help | Unimplemented | `textDocument/signatureHelp` | +| Jump to declaration | Unclear if useful | `textDocument/declaration` | +| Jump to implementation | Unclear if useful | `textDocument/implementation` | +| Folding | Unimplemented | `textDocument/foldingRange` | +| Semantic tokens | Unimplemented | `textDocument/semanticTokens` | +| Linked editing | Unimplemented | `textDocument/linkedEditingRange` | +| Document links | Unimplemented | `textDocument/documentLink` | +| Document color | Unclear if useful | `textDocument/documentColor` | +| Color presentation | Unclear if useful | `textDocument/colorPresentation` | +| Monikers | Unclear if useful | `textDocument/moniker` | 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 e51ad55268..3d2d400154 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: hls-code-range-plugin version: 1.0.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 From 8eb7a3018ec27f3fa9ea90c3d8776677363c6298 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 17 Aug 2022 00:25:44 +0530 Subject: [PATCH 16/31] refactor: use destructuring for createFoldingRange function and use characters --- .../src/Ide/Plugin/CodeRange.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) 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 062ad5bbb8..d1ea2b6c93 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -16,7 +16,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE (IdeAction, @@ -160,17 +160,11 @@ findFoldingRanges r@(CodeRange _ children _) = -- | Parses code range to folding range createFoldingRange :: CodeRange -> Maybe FoldingRange -createFoldingRange node1 = do - let range = _codeRange_range node1 - let Range startPos endPos = range - let Position lineStart _= startPos - let Position lineEnd _ = endPos - let codeRangeKind = _codeRange_kind node1 - - let frk = crkToFrk codeRangeKind +createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position lineEnd charEnd)) _ ck) = do + let frk = crkToFrk ck case frk of - Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) + Just _ -> Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) frk) Nothing -> Nothing -- | Likes 'toCurrentPosition', but works on 'SelectionRange' From 60e3fb26492fffabdc1f7c36d9f39c41786c67b5 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 7 Sep 2022 17:16:59 +0530 Subject: [PATCH 17/31] test: add basic unit test for findFoldingRanges function --- .../src/Ide/Plugin/CodeRange.hs | 1 + .../test/Ide/Plugin/CodeRangeTest.hs | 13 ++++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) 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 d1ea2b6c93..d004aeddd4 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -8,6 +8,7 @@ module Ide.Plugin.CodeRange ( -- * Internal , findPosition + , findFoldingRanges ) where import Control.Monad.Except (ExceptT (ExceptT), diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 73bebf3a2a..00a4e57a1d 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -17,7 +17,7 @@ testTree = 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,16 @@ testTree = ( SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing ) ) + ], + testGroup "findFoldingRanges" $ + let check :: CodeRange -> [FoldingRange] -> Assertion + check codeRange = (findFoldingRanges codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange + mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion + in [ + testCase "General" $ check + (mkCodeRange (Position 1 1) (Position 5 10) []) + [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)] ] ] From e3f0007f2afa3774c0ab27bbd3c0cad5c3db5f4c Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 7 Sep 2022 19:32:58 +0530 Subject: [PATCH 18/31] test: add tests for children and code kind --- .../test/Ide/Plugin/CodeRangeTest.hs | 32 ++++++++++++++++--- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 00a4e57a1d..1f54cbc02d 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -55,11 +55,33 @@ testTree = let check :: CodeRange -> [FoldingRange] -> Assertion check codeRange = (findFoldingRanges codeRange @?=) - mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange - mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange + mkCodeRange start end children crk = CodeRange (Range start end) children crk in [ - testCase "General" $ check - (mkCodeRange (Position 1 1) (Position 5 10) []) - [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)] + -- General test + testCase "Test General Code Block" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) + [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)], + + -- Tests for code kind + testCase "Test Code Kind Region" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) + [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)], + testCase "Test Code Kind Comment" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindComment) + [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeComment)], + testCase "Test Code Kind Import" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindImports) + [FoldingRange 1 (Just 1) 5 (Just 10) (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) [] CodeKindRegion, + mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion + ] CodeKindRegion) + [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion), + FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)] ] ] From 474ffef5983505d81a413e6fb06f6d9740d36e9e Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 7 Sep 2022 20:47:36 +0530 Subject: [PATCH 19/31] test: add more test cases --- .../test/Ide/Plugin/CodeRangeTest.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 1f54cbc02d..296d3475e5 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -82,6 +82,16 @@ testTree = ] CodeKindRegion) [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion), FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), - FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)] + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)], + + -- Single line + testCase "Test Single Line" $ check + (mkCodeRange (Position 1 0) (Position 1 15) [] CodeKindRegion) + [FoldingRange 1 (Just 0) 1 (Just 15) (Just FoldingRangeRegion)], + + -- MultiLine imports + testCase "MultiLine Imports" $ check + (mkCodeRange (Position 1 0) (Position 5 15) [] CodeKindImports) + [FoldingRange 1 (Just 0) 5 (Just 15) (Just FoldingRangeImports)] ] ] From 6975302bd702a660ba525110e1d4b10560b97460 Mon Sep 17 00:00:00 2001 From: sloorush Date: Thu, 8 Sep 2022 11:45:24 +0530 Subject: [PATCH 20/31] test: add test for createFoldingRange --- .../src/Ide/Plugin/CodeRange.hs | 1 + .../test/Ide/Plugin/CodeRangeTest.hs | 24 +++++++++++++++---- 2 files changed, 20 insertions(+), 5 deletions(-) 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 d004aeddd4..e6a4d03029 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -9,6 +9,7 @@ module Ide.Plugin.CodeRange ( -- * Internal , findPosition , findFoldingRanges + , createFoldingRange ) where import Control.Monad.Except (ExceptT (ExceptT), diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 296d3475e5..0a8b7a1a16 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -51,6 +51,7 @@ testTree = ) ) ], + testGroup "findFoldingRanges" $ let check :: CodeRange -> [FoldingRange] -> Assertion check codeRange = (findFoldingRanges codeRange @?=) @@ -81,8 +82,8 @@ testTree = mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion ] CodeKindRegion) [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion), - FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), - FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)], + FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)], -- Single line testCase "Test Single Line" $ check @@ -91,7 +92,20 @@ testTree = -- MultiLine imports testCase "MultiLine Imports" $ check - (mkCodeRange (Position 1 0) (Position 5 15) [] CodeKindImports) - [FoldingRange 1 (Just 0) 5 (Just 15) (Just FoldingRangeImports)] - ] + (mkCodeRange (Position 1 0) (Position 5 15) [] CodeKindImports) + [FoldingRange 1 (Just 0) 5 (Just 15) (Just FoldingRangeImports)] + ], + + 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 test + testCase "Test General Code Block" $ check + (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) + (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion))) + ] ] From a430a43f96f3c91f40aaf2576fc0af04e618cbd4 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sat, 10 Sep 2022 13:13:47 +0530 Subject: [PATCH 21/31] test: add integration test for folding ranges --- plugins/hls-code-range-plugin/test/Main.hs | 28 ++++++++++++++++++- .../folding-range/Function.golden.txt | 20 +++++++++++++ .../test/testdata/folding-range/Function.hs | 8 ++++++ .../test/testdata/folding-range/hie.yaml | 4 +++ 4 files changed, 59 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt create mode 100644 plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs create mode 100644 plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index bffc3f716e..1738c41fbe 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -28,7 +28,8 @@ main = do testGroup "Code Range" [ testGroup "Integration Tests" [ makeSelectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)], - makeSelectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)] + makeSelectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)], + foldingRangeGoldenTest recorder "Function" ], testGroup "Unit Tests" [ Ide.Plugin.CodeRangeTest.testTree, @@ -64,3 +65,28 @@ makeSelectionRangeGoldenTest recorder testName positions = goldenGitDiff testNam showPosition :: Position -> ByteString showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" showLBS = fromString . show + +foldingRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> TestTree +foldingRangeGoldenTest recorder testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer (plugin recorder) 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/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt new file mode 100644 index 0000000000..78314b9f45 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt @@ -0,0 +1,20 @@ +((4, 0) : (7, 21)) : FoldingRangeRegion +((4, 0) : (4, 25)) : FoldingRangeRegion +((4, 0) : (4, 6)) : FoldingRangeRegion +((4, 10) : (4, 25)) : FoldingRangeRegion +((4, 10) : (4, 17)) : FoldingRangeRegion +((4, 21) : (4, 25)) : FoldingRangeRegion +((5, 0) : (7, 21)) : FoldingRangeRegion +((5, 0) : (5, 6)) : FoldingRangeRegion +((5, 7) : (5, 8)) : FoldingRangeRegion +((5, 9) : (7, 21)) : FoldingRangeRegion +((5, 11) : (7, 21)) : FoldingRangeRegion +((5, 14) : (5, 28)) : FoldingRangeRegion +((5, 14) : (5, 23)) : FoldingRangeRegion +((5, 14) : (5, 15)) : FoldingRangeRegion +((5, 16) : (5, 21)) : FoldingRangeRegion +((5, 22) : (5, 23)) : FoldingRangeRegion +((5, 24) : (5, 26)) : FoldingRangeRegion +((5, 27) : (5, 28)) : FoldingRangeRegion +((6, 16) : (6, 20)) : FoldingRangeRegion +((7, 16) : (7, 21)) : FoldingRangeRegion \ No newline at end of file diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs new file mode 100644 index 0000000000..4a79afadac --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use module export list" #-} +module FuncMultiMatch where + +isEven :: Integer -> Bool +isEven n = if n `mod` 2 == 0 + then True + else False diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml b/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml new file mode 100644 index 0000000000..22a5941a9b --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - "Function" From baf419e3fe0ab6510335f780c21869464f04e830 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sun, 11 Sep 2022 23:50:07 +0530 Subject: [PATCH 22/31] fix: duplicate start line foldingranges and remove single line foldingranges --- .../src/Ide/Plugin/CodeRange.hs | 15 +++++++++++--- .../test/Ide/Plugin/CodeRangeTest.hs | 8 ++++++-- .../folding-range/Function.golden.txt | 20 +------------------ 3 files changed, 19 insertions(+), 24 deletions(-) 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 e6a4d03029..3a09ded67c 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -79,7 +79,7 @@ foldingRangeHandler ide _ FoldingRangeParams{..} = do toNormalizedFilePath' <$> uriToFilePath' uri foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ getFoldingRanges filePath - pure . List $ foldingRanges + pure . List $ removeDupStartLineFoldings foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -164,11 +164,20 @@ findFoldingRanges r@(CodeRange _ children _) = createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position lineEnd charEnd)) _ ck) = do let frk = crkToFrk ck - - case frk of + if lineStart == lineEnd + then Nothing + else case frk of Just _ -> Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) frk) Nothing -> Nothing +-- Removes all small foldings that start from the same line +removeDupStartLineFoldings :: [FoldingRange] -> [FoldingRange] +removeDupStartLineFoldings [] = [] +removeDupStartLineFoldings [x] = [x] +removeDupStartLineFoldings (frx@(FoldingRange x _ _ _ _):xs@((FoldingRange y _ _ _ _):xs2)) + | x == y = removeDupStartLineFoldings ([frx]++xs2) + | otherwise = frx : removeDupStartLineFoldings xs + -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange toCurrentSelectionRange positionMapping SelectionRange{..} = do diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 0a8b7a1a16..290fe381ba 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -88,7 +88,7 @@ testTree = -- Single line testCase "Test Single Line" $ check (mkCodeRange (Position 1 0) (Position 1 15) [] CodeKindRegion) - [FoldingRange 1 (Just 0) 1 (Just 15) (Just FoldingRangeRegion)], + [], -- MultiLine imports testCase "MultiLine Imports" $ check @@ -106,6 +106,10 @@ testTree = -- General test 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 FoldingRangeRegion))), + -- General test + testCase "Test Same Start Line" $ check + (mkCodeRange (Position 1 1) (Position 1 10) [] CodeKindRegion) + Nothing ] ] diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt index 78314b9f45..efcf7e7d99 100644 --- a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt @@ -1,20 +1,2 @@ ((4, 0) : (7, 21)) : FoldingRangeRegion -((4, 0) : (4, 25)) : FoldingRangeRegion -((4, 0) : (4, 6)) : FoldingRangeRegion -((4, 10) : (4, 25)) : FoldingRangeRegion -((4, 10) : (4, 17)) : FoldingRangeRegion -((4, 21) : (4, 25)) : FoldingRangeRegion -((5, 0) : (7, 21)) : FoldingRangeRegion -((5, 0) : (5, 6)) : FoldingRangeRegion -((5, 7) : (5, 8)) : FoldingRangeRegion -((5, 9) : (7, 21)) : FoldingRangeRegion -((5, 11) : (7, 21)) : FoldingRangeRegion -((5, 14) : (5, 28)) : FoldingRangeRegion -((5, 14) : (5, 23)) : FoldingRangeRegion -((5, 14) : (5, 15)) : FoldingRangeRegion -((5, 16) : (5, 21)) : FoldingRangeRegion -((5, 22) : (5, 23)) : FoldingRangeRegion -((5, 24) : (5, 26)) : FoldingRangeRegion -((5, 27) : (5, 28)) : FoldingRangeRegion -((6, 16) : (6, 20)) : FoldingRangeRegion -((7, 16) : (7, 21)) : FoldingRangeRegion \ No newline at end of file +((5, 0) : (7, 21)) : FoldingRangeRegion \ No newline at end of file From e9dc5698cec7479957c08c0861e6a2aae3997745 Mon Sep 17 00:00:00 2001 From: sloorush Date: Mon, 12 Sep 2022 13:36:21 +0530 Subject: [PATCH 23/31] refactor: duplicate folding range functionality --- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 3a09ded67c..ca28273e7e 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -175,7 +175,7 @@ removeDupStartLineFoldings :: [FoldingRange] -> [FoldingRange] removeDupStartLineFoldings [] = [] removeDupStartLineFoldings [x] = [x] removeDupStartLineFoldings (frx@(FoldingRange x _ _ _ _):xs@((FoldingRange y _ _ _ _):xs2)) - | x == y = removeDupStartLineFoldings ([frx]++xs2) + | x == y = removeDupStartLineFoldings (frx:xs2) | otherwise = frx : removeDupStartLineFoldings xs -- | Likes 'toCurrentPosition', but works on 'SelectionRange' From c46a7f48612df26396368fb99b91ed62454e74b9 Mon Sep 17 00:00:00 2001 From: sloorush Date: Mon, 12 Sep 2022 19:16:12 +0530 Subject: [PATCH 24/31] fix: formatting in code range plugin --- .../hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs | 3 +-- .../test/testdata/selection-range/Import.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 2d61fea8f1..9871a159ca 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -46,8 +46,7 @@ import Development.IDE 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 (..), diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs index 9159c29d49..aa388cacb7 100644 --- a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs @@ -1,4 +1,4 @@ module MultiPositions where -import Data.List (find) import qualified Data.Foldable (foldl, foldl') +import Data.List (find) From 959a53ba81a0467c719eeb816d2f1173b19af69f Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 14 Sep 2022 23:25:35 +0530 Subject: [PATCH 25/31] added more descriptive comments and encorporate code review suggestions --- docs/features.md | 1 - .../src/Ide/Plugin/CodeRange.hs | 49 ++++++++++++++----- .../test/Ide/Plugin/CodeRangeTest.hs | 6 +-- 3 files changed, 40 insertions(+), 16 deletions(-) diff --git a/docs/features.md b/docs/features.md index 5a48ab7412..4154b72b53 100644 --- a/docs/features.md +++ b/docs/features.md @@ -370,7 +370,6 @@ Contributions welcome! | Signature help | Unimplemented | `textDocument/signatureHelp` | | Jump to declaration | Unclear if useful | `textDocument/declaration` | | Jump to implementation | Unclear if useful | `textDocument/implementation` | -| Folding | Unimplemented | `textDocument/foldingRange` | | Semantic tokens | Unimplemented | `textDocument/semanticTokens` | | Linked editing | Unimplemented | `textDocument/linkedEditingRange` | | Document links | Unimplemented | `textDocument/documentLink` | 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 ca28273e7e..857d34a370 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -88,9 +88,7 @@ getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange getFoldingRanges file = do (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - let foldingRanges = findFoldingRanges codeRange - - maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) + pure $ findFoldingRanges codeRange selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do @@ -150,32 +148,59 @@ findPosition pos root = go Nothing root startOfRight <- _start . _codeRange_range <$> V.headM right if pos < startOfRight then binarySearchPos left else binarySearchPos right --- | Traverses through the code range and children to a folding ranges +-- | 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. findFoldingRanges :: CodeRange -> [FoldingRange] findFoldingRanges r@(CodeRange _ children _) = - let frRoot :: [FoldingRange] = case createFoldingRange r of - Just x -> [x] + let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children + in case createFoldingRange r of + Just x -> x:frChildren Nothing -> [] - frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children - in frRoot ++ 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 + + -- Filtering code ranges that start and end on the same line as need/can not be folded. + -- + -- Eg. A single line function will also generate a Folding Range but it cannot be folded + -- because it is already single line, so omiting it. if lineStart == lineEnd then Nothing else case frk of Just _ -> Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) frk) Nothing -> Nothing --- Removes all small foldings that start from the same line +-- | Removes all small foldings that start from the same line. +-- +-- 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. +-- +-- This function preserves the largest folding range from the ranges that 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. +-- +-- This is done by breaking the [FoldingRange] into parts --> +-- frx: Head +-- xs: rest of the array +-- fry(not shown as it is not used): head of xs +-- xs2: rest of the array other than the first two elements +-- slx and sly: start line of frx and fry +-- +-- We compare the start line of the first two elements in the array and if the start line is the same we remove the +-- second one as it is the smaller one amoung the two. +-- otherwise frx is returned and the function runs recursively on xs. removeDupStartLineFoldings :: [FoldingRange] -> [FoldingRange] removeDupStartLineFoldings [] = [] removeDupStartLineFoldings [x] = [x] -removeDupStartLineFoldings (frx@(FoldingRange x _ _ _ _):xs@((FoldingRange y _ _ _ _):xs2)) - | x == y = removeDupStartLineFoldings (frx:xs2) +removeDupStartLineFoldings (frx@(FoldingRange slx _ _ _ _):xs@((FoldingRange sly _ _ _ _):xs2)) + | slx == sly = removeDupStartLineFoldings (frx:xs2) | otherwise = frx : removeDupStartLineFoldings xs -- | Likes 'toCurrentPosition', but works on 'SelectionRange' diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 290fe381ba..4474da90a9 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -85,7 +85,7 @@ testTree = FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)], - -- Single line + -- Single line returns [] because single line ranges need not be folded testCase "Test Single Line" $ check (mkCodeRange (Position 1 0) (Position 1 15) [] CodeKindRegion) [], @@ -103,11 +103,11 @@ testTree = mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRangeKind -> CodeRange mkCodeRange start end children crk = CodeRange (Range start end) children crk in [ - -- General test + -- 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))), - -- General test + -- 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) Nothing From e8ee9f9d75052c41901948d17e4af91d848bbb68 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 14 Sep 2022 23:45:27 +0530 Subject: [PATCH 26/31] revert: automatic formatting for selection range test case file --- .../test/testdata/selection-range/Import.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs index aa388cacb7..200478a169 100644 --- a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs @@ -1,4 +1,4 @@ module MultiPositions where -import qualified Data.Foldable (foldl, foldl') -import Data.List (find) +import Data.List (find) +import qualified Data.Foldable (foldl, foldl') \ No newline at end of file From 44c5819699475a22bec2c486ff21df9c4b687a57 Mon Sep 17 00:00:00 2001 From: sloorush Date: Sun, 18 Sep 2022 16:47:38 +0530 Subject: [PATCH 27/31] fix: ignoring children if root fails to provide folding ranges --- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 857d34a370..11bd236f03 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -157,7 +157,7 @@ findFoldingRanges r@(CodeRange _ children _) = let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children in case createFoldingRange r of Just x -> x:frChildren - Nothing -> [] + Nothing -> frChildren -- | Parses code range to folding range createFoldingRange :: CodeRange -> Maybe FoldingRange From 9181b04ca60acb548697764a09be1721c3dd3407 Mon Sep 17 00:00:00 2001 From: sloorush Date: Mon, 19 Sep 2022 18:42:34 +0530 Subject: [PATCH 28/31] remove: redundant match on crkToFrk --- .../hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs | 4 +--- .../src/Ide/Plugin/CodeRange/Rules.hs | 9 ++++----- 2 files changed, 5 insertions(+), 8 deletions(-) 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 11bd236f03..920017995d 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -171,9 +171,7 @@ createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position li -- because it is already single line, so omiting it. if lineStart == lineEnd then Nothing - else case frk of - Just _ -> Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) frk) - Nothing -> Nothing + else Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk)) -- | Removes all small foldings that start from the same line. -- diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 9871a159ca..13a2dd3847 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -193,9 +193,8 @@ handleError recorder action' = do Right value -> pure $ toIdeResult (Right value) -- | Maps type CodeRangeKind to FoldingRangeKind -crkToFrk :: CodeRangeKind -> Maybe FoldingRangeKind +crkToFrk :: CodeRangeKind -> FoldingRangeKind crkToFrk crk = case crk of - CodeKindComment -> Just FoldingRangeComment - CodeKindImports -> Just FoldingRangeImports - CodeKindRegion -> Just FoldingRangeRegion - _ -> Nothing + CodeKindComment -> FoldingRangeComment + CodeKindImports -> FoldingRangeImports + CodeKindRegion -> FoldingRangeRegion From 86f10689f1811d5382e8551fcd52b8a50525417c Mon Sep 17 00:00:00 2001 From: sloorush Date: Mon, 19 Sep 2022 19:31:45 +0530 Subject: [PATCH 29/31] revert: filtering same line foldings and multiple foldings on the same line as it can be handled by clients --- .../src/Ide/Plugin/CodeRange.hs | 53 ++++++------------- .../test/Ide/Plugin/CodeRangeTest.hs | 8 ++- .../folding-range/Function.golden.txt | 20 ++++++- 3 files changed, 42 insertions(+), 39 deletions(-) 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 920017995d..e97ce87241 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -79,7 +79,7 @@ foldingRangeHandler ide _ FoldingRangeParams{..} = do toNormalizedFilePath' <$> uriToFilePath' uri foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ getFoldingRanges filePath - pure . List $ removeDupStartLineFoldings foldingRanges + pure . List $ foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -152,6 +152,21 @@ findPosition pos root = go Nothing root -- -- 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 r@(CodeRange _ children _) = let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children @@ -165,41 +180,7 @@ createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position li -- Type conversion of codeRangeKind to FoldingRangeKind let frk = crkToFrk ck - -- Filtering code ranges that start and end on the same line as need/can not be folded. - -- - -- Eg. A single line function will also generate a Folding Range but it cannot be folded - -- because it is already single line, so omiting it. - if lineStart == lineEnd - then Nothing - else Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk)) - --- | Removes all small foldings that start from the same line. --- --- 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. --- --- This function preserves the largest folding range from the ranges that 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. --- --- This is done by breaking the [FoldingRange] into parts --> --- frx: Head --- xs: rest of the array --- fry(not shown as it is not used): head of xs --- xs2: rest of the array other than the first two elements --- slx and sly: start line of frx and fry --- --- We compare the start line of the first two elements in the array and if the start line is the same we remove the --- second one as it is the smaller one amoung the two. --- otherwise frx is returned and the function runs recursively on xs. -removeDupStartLineFoldings :: [FoldingRange] -> [FoldingRange] -removeDupStartLineFoldings [] = [] -removeDupStartLineFoldings [x] = [x] -removeDupStartLineFoldings (frx@(FoldingRange slx _ _ _ _):xs@((FoldingRange sly _ _ _ _):xs2)) - | slx == sly = removeDupStartLineFoldings (frx:xs2) - | otherwise = frx : removeDupStartLineFoldings xs + Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk)) -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 4474da90a9..8495b1ee4d 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -52,6 +52,10 @@ testTree = ) ], + -- 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 @?=) @@ -88,7 +92,7 @@ testTree = -- Single line returns [] because single line ranges need not be folded testCase "Test Single Line" $ check (mkCodeRange (Position 1 0) (Position 1 15) [] CodeKindRegion) - [], + [FoldingRange 1 (Just 0) 1 (Just 15) (Just FoldingRangeRegion)], -- MultiLine imports testCase "MultiLine Imports" $ check @@ -110,6 +114,6 @@ testTree = -- 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) - Nothing + (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeRegion))) ] ] diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt index efcf7e7d99..78314b9f45 100644 --- a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt @@ -1,2 +1,20 @@ ((4, 0) : (7, 21)) : FoldingRangeRegion -((5, 0) : (7, 21)) : FoldingRangeRegion \ No newline at end of file +((4, 0) : (4, 25)) : FoldingRangeRegion +((4, 0) : (4, 6)) : FoldingRangeRegion +((4, 10) : (4, 25)) : FoldingRangeRegion +((4, 10) : (4, 17)) : FoldingRangeRegion +((4, 21) : (4, 25)) : FoldingRangeRegion +((5, 0) : (7, 21)) : FoldingRangeRegion +((5, 0) : (5, 6)) : FoldingRangeRegion +((5, 7) : (5, 8)) : FoldingRangeRegion +((5, 9) : (7, 21)) : FoldingRangeRegion +((5, 11) : (7, 21)) : FoldingRangeRegion +((5, 14) : (5, 28)) : FoldingRangeRegion +((5, 14) : (5, 23)) : FoldingRangeRegion +((5, 14) : (5, 15)) : FoldingRangeRegion +((5, 16) : (5, 21)) : FoldingRangeRegion +((5, 22) : (5, 23)) : FoldingRangeRegion +((5, 24) : (5, 26)) : FoldingRangeRegion +((5, 27) : (5, 28)) : FoldingRangeRegion +((6, 16) : (6, 20)) : FoldingRangeRegion +((7, 16) : (7, 21)) : FoldingRangeRegion \ No newline at end of file From 57cb482c5b59fd73abce15e193ab558a11f6f22e Mon Sep 17 00:00:00 2001 From: sloorush Date: Mon, 19 Sep 2022 20:20:50 +0530 Subject: [PATCH 30/31] revert: formatting change to selection range test file --- .../test/testdata/selection-range/Import.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs index 200478a169..9159c29d49 100644 --- a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs @@ -1,4 +1,4 @@ module MultiPositions where import Data.List (find) -import qualified Data.Foldable (foldl, foldl') \ No newline at end of file +import qualified Data.Foldable (foldl, foldl') From ccd9fa53b9223ab16e9c85df038ce1aabd41a7a5 Mon Sep 17 00:00:00 2001 From: sloorush Date: Wed, 21 Sep 2022 10:11:27 +0530 Subject: [PATCH 31/31] fix: entire file folding because of root node --- .../src/Ide/Plugin/CodeRange.hs | 4 ++-- .../folding-range/Function.golden.txt | 23 ++++++++++++++++++- .../test/testdata/folding-range/Function.hs | 7 +++++- 3 files changed, 30 insertions(+), 4 deletions(-) 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 e97ce87241..75fb1eca53 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -88,7 +88,8 @@ getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange getFoldingRanges file = do (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - pure $ findFoldingRanges codeRange + -- removing first node because it folds the entire file + pure $ drop 1 $ findFoldingRanges codeRange selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do @@ -179,7 +180,6 @@ 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' diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt index 78314b9f45..b7af2a60a0 100644 --- a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt @@ -1,3 +1,4 @@ +((2, 16) : (2, 22)) : FoldingRangeRegion ((4, 0) : (7, 21)) : FoldingRangeRegion ((4, 0) : (4, 25)) : FoldingRangeRegion ((4, 0) : (4, 6)) : FoldingRangeRegion @@ -17,4 +18,24 @@ ((5, 24) : (5, 26)) : FoldingRangeRegion ((5, 27) : (5, 28)) : FoldingRangeRegion ((6, 16) : (6, 20)) : FoldingRangeRegion -((7, 16) : (7, 21)) : FoldingRangeRegion \ No newline at end of file +((7, 16) : (7, 21)) : FoldingRangeRegion +((9, 0) : (12, 20)) : FoldingRangeRegion +((9, 0) : (9, 24)) : FoldingRangeRegion +((9, 0) : (9, 5)) : FoldingRangeRegion +((9, 9) : (9, 24)) : FoldingRangeRegion +((9, 9) : (9, 16)) : FoldingRangeRegion +((9, 20) : (9, 24)) : FoldingRangeRegion +((10, 0) : (12, 20)) : FoldingRangeRegion +((10, 0) : (10, 5)) : FoldingRangeRegion +((10, 6) : (10, 7)) : FoldingRangeRegion +((10, 8) : (12, 20)) : FoldingRangeRegion +((10, 10) : (12, 20)) : FoldingRangeRegion +((10, 13) : (10, 27)) : FoldingRangeRegion +((10, 13) : (10, 22)) : FoldingRangeRegion +((10, 13) : (10, 14)) : FoldingRangeRegion +((10, 15) : (10, 20)) : FoldingRangeRegion +((10, 21) : (10, 22)) : FoldingRangeRegion +((10, 23) : (10, 25)) : FoldingRangeRegion +((10, 26) : (10, 27)) : FoldingRangeRegion +((11, 16) : (11, 21)) : FoldingRangeRegion +((12, 16) : (12, 20)) : FoldingRangeRegion \ No newline at end of file diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs index 4a79afadac..b73bece14f 100644 --- a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.hs @@ -1,8 +1,13 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use module export list" #-} -module FuncMultiMatch where +module Function(isEven) where isEven :: Integer -> Bool isEven n = if n `mod` 2 == 0 then True else False + +isOdd :: Integer -> Bool +isOdd n = if n `mod` 2 == 0 + then False + else True