From fd862676b36d1d1a390b0642660235102795d833 Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Tue, 25 Aug 2020 13:39:47 +0300 Subject: [PATCH] [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 | 105 +++++++++++++++----------- tools/lsp/squirrel/src/AST.hs | 3 +- tools/lsp/squirrel/src/AST/Folding.hs | 45 +++++++++++ 3 files changed, 106 insertions(+), 47 deletions(-) diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 60a65ab27..9eaf7107b 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -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 diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index 1c38cbb13..566315291 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/AST/Folding.hs b/tools/lsp/squirrel/src/AST/Folding.hs index dcc6afacd..c7d52fb6b 100644 --- a/tools/lsp/squirrel/src/AST/Folding.hs +++ b/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 + } +