[LIGO-26] Support code folding capability

Problem: We want to support code folding for functions and types
in our lsp.

Solution: Add `foldingAST` function that produces an additional
list of ranges along with the given monad used in `haskell-lsp`
API to collect ranges that are consequently sent to server.

tools/lsp/squirrel/app/Main.hs

@@ -1,39 +1,39 @@
 
-import           Control.Concurrent
+import Control.Arrow
-import           Control.Arrow
+import Control.Concurrent
-import           Control.Concurrent.STM
+import Control.Concurrent.STM
-import           Control.Exception                     as E
+import Control.Exception as E
-import           Control.Lens
+import Control.Lens
-import           Control.Monad
+import Control.Monad
 
-import           Data.Default
+import Data.Default
 -- import           Data.Foldable
-import qualified Data.Text                             as Text
+import Data.String (fromString)
-import           Data.Text                                     (Text)
+import Data.String.Interpolate (i)
-import           Data.String                                   (fromString)
+import Data.Text (Text)
-import           Data.String.Interpolate                       (i)
+import qualified Data.Text as Text
 
-import qualified Language.Haskell.LSP.Control          as CTRL
+import qualified Language.Haskell.LSP.Control as CTRL
-import qualified Language.Haskell.LSP.Core             as Core
+import qualified Language.Haskell.LSP.Core as Core
-import           Language.Haskell.LSP.Diagnostics
+import Language.Haskell.LSP.Diagnostics
-import           Language.Haskell.LSP.Messages         as Msg
+import Language.Haskell.LSP.Messages as Msg
-import qualified Language.Haskell.LSP.Types            as J
+import qualified Language.Haskell.LSP.Types as J
-import qualified Language.Haskell.LSP.Types.Lens       as J
+import qualified Language.Haskell.LSP.Types.Lens as J
-import qualified Language.Haskell.LSP.Utility          as U
+import qualified Language.Haskell.LSP.Utility as U
-import           Language.Haskell.LSP.VFS
+import Language.Haskell.LSP.VFS
 
-import           System.Exit
+import System.Exit
-import qualified System.Log                            as L
+import qualified System.Log as L
 
-import           Duplo.Error
+import Duplo.Error
-import           Duplo.Pretty
+import Duplo.Pretty
-import           Duplo.Tree (collect)
+import Duplo.Tree (collect)
 
-import           Range
+import AST hiding (def)
-import           Product
+import qualified AST.Find as Find
-import           AST                                           hiding (def)
-import qualified AST.Find                              as Find
 import Data.Maybe (fromMaybe)
+import Product
+import Range
 -- import           Error
 
 main :: IO ()
@@ -81,21 +81,23 @@ lspOptions = def
   }
 
 lspHandlers :: TChan FromClientMessage -> Core.Handlers
-lspHandlers rin = def
+lspHandlers rin =
-  { Core.initializedHandler                       = Just $ passHandler rin NotInitialized
+  def
-  , Core.definitionHandler                        = Just $ passHandler rin ReqDefinition
+    { Core.initializedHandler = Just $ passHandler rin NotInitialized,
-  , Core.referencesHandler                        = Just $ passHandler rin ReqFindReferences
+      Core.definitionHandler = Just $ passHandler rin ReqDefinition,
-  , Core.didOpenTextDocumentNotificationHandler   = Just $ passHandler rin NotDidOpenTextDocument
+      Core.referencesHandler = Just $ passHandler rin ReqFindReferences,
-  , Core.didSaveTextDocumentNotificationHandler   = Just $ passHandler rin NotDidSaveTextDocument
+      Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument,
-  , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
+      Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument,
-  , Core.didCloseTextDocumentNotificationHandler  = Just $ passHandler rin NotDidCloseTextDocument
+      Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument,
-  , Core.cancelNotificationHandler                = Just $ passHandler rin NotCancelRequestFromClient
+      Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument,
-  , Core.responseHandler                          = Just $ responseHandlerCb rin
+      Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient,
-  -- , Core.codeActionHandler                        = Just $ passHandler rin ReqCodeAction
+      Core.responseHandler = Just $ responseHandlerCb rin,
-  -- , Core.executeCommandHandler                    = Just $ passHandler rin ReqExecuteCommand
+      -- , Core.codeActionHandler                        = Just $ passHandler rin ReqCodeAction
-  , Core.completionHandler                        = Just $ passHandler rin ReqCompletion
+      -- , Core.executeCommandHandler                    = Just $ passHandler rin ReqExecuteCommand
-  , Core.completionResolveHandler                 = Just $ passHandler rin ReqCompletionItemResolve
+      Core.completionHandler = Just $ passHandler rin ReqCompletion,
-  }
+      -- , Core.completionResolveHandler                 = Just $ passHandler rin ReqCompletionItemResolve
+      Core.foldingRangeHandler = Just $ passHandler rin ReqFoldingRange
+    }
 
 passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a
 passHandler rin c notification = do
@@ -151,7 +153,6 @@ eventLoop funs chan = do
           (J.toNormalizedUri doc)
           (J.uriToFilePath doc)
           (Just ver)
-
       NotDidChangeTextDocument notif -> do
         let
           doc = notif
@@ -186,7 +187,6 @@ eventLoop funs chan = do
               respondWith funs req RspFindReferences $ J.List locations
             Nothing -> do
               respondWith funs req RspFindReferences $ J.List []
-
       ReqCompletion req -> do
         stopDyingAlready funs req $ do
           U.logs $ "got completion request: " <> show req
@@ -201,7 +201,20 @@ eventLoop funs chan = do
         stopDyingAlready funs req $ do
           U.logs $ "got completion resolve request: " <> show req
           respondWith funs req RspCompletionItemResolve (req ^. J.params)
-
+      ReqFoldingRange req -> do
+        stopDyingAlready funs req $ do
+          let uri = req ^. J.params . J.textDocument . J.uri
+          tree <- loadFromVFS funs uri
+          let response =
+                RspFoldingRange
+                  . Core.makeResponseMessage req
+                  . J.List
+              handler =
+                Core.sendFunc funs
+                  . response
+                  . fmap toFoldingRange
+          actions <- foldingAST tree
+          handler actions
       _ -> U.logs "unknown msg"
 
 respondWith

tools/lsp/squirrel/src/AST.hs

@@ -3,6 +3,7 @@ module AST (module M) where
 
 import AST.Completion as M
 import AST.Find as M
+import AST.Folding as M
+import AST.Parser as M
 import AST.Scope as M
 import AST.Skeleton as M
-import AST.Parser as M

tools/lsp/squirrel/src/AST/Folding.hs

@@ -1,3 +1,48 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Code folding utilities
 
 module AST.Folding where
 
+import qualified Language.Haskell.LSP.Types as J
+
+import Duplo.Tree
+
+import AST.Scope
+import AST.Skeleton
+import Control.Monad.Catch.Pure (MonadCatch)
+
+import Control.Monad.Writer.Strict
+import Product
+import Range
+
+-- | Fold the given ast by visiting its nodes and applying provided
+-- handler to them. This is used primarly to call `Core.sendFunc`
+-- at each specific node we face.
+-- TODO: may affect perfomance, if so we need to use `Endo` instead.
+foldingAST
+  :: (MonadCatch m)
+  => LIGO Info'
+  -> m [Range]
+foldingAST = execWriterT . visit handlers
+  where
+    handlers =
+      [ Visit @Binding $ \case
+          (getElem @Range -> r, Function {}) -> tell [r]
+          (getElem @Range -> r, TypeDecl {}) -> tell [r]
+          -- TODO: include blocks?
+          _ -> pure ()
+      ]
+
+toFoldingRange :: Range -> J.FoldingRange
+toFoldingRange Range
+  { rStart  = (_startLine, Just -> _startCharacter, _)
+  , rFinish = (_endLine, Just -> _endCharacter, _)
+  } = J.FoldingRange
+  { _startLine
+  , _startCharacter
+  , _endLine
+  , _endCharacter
+  , _kind = Just J.FoldingRangeRegion
+  }
+