Feat: Folding Ranges

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`                                                                         |
@@ -100,7 +100,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`        |
@@ -261,6 +261,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.
 
@@ -337,6 +338,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`
@@ -354,15 +365,14 @@ 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`                  |
+| 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`                         |

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

@@ -429,6 +429,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
@@ -529,6 +536,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/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 <https://github.com/haskell/haskell-language-server#readme>

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

@@ -1,12 +1,15 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Ide.Plugin.CodeRange (
     descriptor
     , Log
 
     -- * Internal
     , findPosition
+    , findFoldingRanges
+    , createFoldingRange
     ) where
 
 import           Control.Monad.Except                 (ExceptT (ExceptT),
@@ -33,7 +36,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,12 +45,14 @@ 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),
@@ -57,8 +62,7 @@ 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 +72,24 @@ 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 $ removeDupStartLineFoldings 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
+
+    pure $ findFoldingRanges codeRange
+
 selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange))
 selectionRangeHandler ide _ SelectionRangeParams{..} = do
     pluginResponse $ do
@@ -126,6 +148,61 @@ 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 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 frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children
+    in case createFoldingRange r of
+        Just x  -> x:frChildren
+        Nothing -> []
+
+-- | 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.
+--
+-- 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
+
 -- | 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

@@ -21,6 +21,7 @@ module Ide.Plugin.CodeRange.Rules
     -- * Internal
     , removeInterleaving
     , simplify
+    , crkToFrk
     ) where
 
 import           Control.DeepSeq                    (NFData)
@@ -45,14 +46,14 @@ 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 (..),
                                                      PreProcessEnv (..),
                                                      isCustomNode,
                                                      preProcessAST)
+import           Language.LSP.Types                 (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion))
 import           Language.LSP.Types.Lens            (HasEnd (end),
                                                      HasStart (start))
 import           Prelude                            hiding (log)
@@ -90,7 +91,7 @@ data CodeRangeKind =
   | CodeKindImports
   -- | a comment
   | CodeKindComment
-    deriving (Show, Generic, NFData)
+    deriving (Show, Eq, Generic, NFData)
 
 Lens.makeLenses ''CodeRange
 
@@ -190,3 +191,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