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 .:? "foldingRangeOn" .!= plcFoldingRangeOn def
       <*> o .:? "config"           .!= plcConfig        def
 
 -- ---------------------------------------------------------------------

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
@@ -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 = sconcat x
+
 instance PluginRequestMethod CallHierarchyIncomingCalls where
 
 instance PluginRequestMethod CallHierarchyOutgoingCalls where

plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs

@@ -1,13 +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)
@@ -33,7 +35,7 @@ import           Development.IDE.Core.PositionMapping (PositionMapping,
 import           Development.IDE.Types.Logger         (Pretty (..))
 import           Ide.Plugin.CodeRange.Rules           (CodeRange (..),
                                                        GetCodeRange (..),
-                                                       codeRangeRule)
+                                                       codeRangeRule, crkToFrk)
 import qualified Ide.Plugin.CodeRange.Rules           as Rules (Log)
 import           Ide.PluginUtils                      (pluginResponse,
                                                        positionInRange)
@@ -42,40 +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),
+                                                       SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange),
                                                        SelectionRange (..),
                                                        SelectionRangeParams (..),
                                                        TextDocumentIdentifier (TextDocumentIdentifier),
                                                        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
-    , 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
+
+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)
 
 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
@@ -85,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
@@ -106,31 +136,58 @@ 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
         acc' = Just $ maybe (SelectionRange range Nothing) (SelectionRange range . Just) acc
 
     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]
+        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 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
-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
-    }
+      }