Feat: Folding Ranges

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
 
 -- ---------------------------------------------------------------------

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

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,
@@ -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)
@@ -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, FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)
+ )
 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,26 @@ 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 = catMaybes $ 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
  pluginResponse $ do
@@ -126,6 +148,42 @@ 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
+
+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
+
 -- | Likes 'toCurrentPosition', but works on 'SelectionRange'
 toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange
 toCurrentSelectionRange positionMapping SelectionRange{..} = do

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