[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.
This commit is contained in:
Anton Myasnikov
parent
d2a020434e
commit
fd862676b3
@ -1,39 +1,39 @@
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Arrow
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception as E
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Arrow
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception as E
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
|
||||
import Data.Default
|
||||
import Data.Default
|
||||
-- import Data.Foldable
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text (Text)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Interpolate (i)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Interpolate (i)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import qualified Language.Haskell.LSP.Control as CTRL
|
||||
import qualified Language.Haskell.LSP.Core as Core
|
||||
import Language.Haskell.LSP.Diagnostics
|
||||
import Language.Haskell.LSP.Messages as Msg
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
import qualified Language.Haskell.LSP.Utility as U
|
||||
import Language.Haskell.LSP.VFS
|
||||
import qualified Language.Haskell.LSP.Control as CTRL
|
||||
import qualified Language.Haskell.LSP.Core as Core
|
||||
import Language.Haskell.LSP.Diagnostics
|
||||
import Language.Haskell.LSP.Messages as Msg
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
import qualified Language.Haskell.LSP.Utility as U
|
||||
import Language.Haskell.LSP.VFS
|
||||
|
||||
import System.Exit
|
||||
import qualified System.Log as L
|
||||
import System.Exit
|
||||
import qualified System.Log as L
|
||||
|
||||
import Duplo.Error
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree (collect)
|
||||
import Duplo.Error
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree (collect)
|
||||
|
||||
import Range
|
||||
import Product
|
||||
import AST hiding (def)
|
||||
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
|
||||
{ Core.initializedHandler = Just $ passHandler rin NotInitialized
|
||||
, Core.definitionHandler = Just $ passHandler rin ReqDefinition
|
||||
, Core.referencesHandler = Just $ passHandler rin ReqFindReferences
|
||||
, Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
|
||||
, Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
|
||||
, Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
|
||||
, Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
|
||||
, Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
|
||||
, Core.responseHandler = Just $ responseHandlerCb rin
|
||||
-- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
|
||||
-- , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
|
||||
, Core.completionHandler = Just $ passHandler rin ReqCompletion
|
||||
, Core.completionResolveHandler = Just $ passHandler rin ReqCompletionItemResolve
|
||||
}
|
||||
lspHandlers rin =
|
||||
def
|
||||
{ Core.initializedHandler = Just $ passHandler rin NotInitialized,
|
||||
Core.definitionHandler = Just $ passHandler rin ReqDefinition,
|
||||
Core.referencesHandler = Just $ passHandler rin ReqFindReferences,
|
||||
Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument,
|
||||
Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument,
|
||||
Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument,
|
||||
Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument,
|
||||
Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient,
|
||||
Core.responseHandler = Just $ responseHandlerCb rin,
|
||||
-- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
|
||||
-- , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user