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