Call hierarchy support

cabal.project

@@ -10,3 +10,8 @@ tests: True
 benchmarks: True
 test-show-details: direct
 haddock-quickjump: True
+
+constraints: some == 1.0.1,
+             dependent-sum == 0.7.1.0
+
+max-backjumps: 10000

lsp-test/src/Language/LSP/Test.hs

@@ -94,6 +94,9 @@ module Language.LSP.Test
   , getCodeLenses
   -- ** Capabilities
   , getRegisteredCapabilities
+  , prepareCallHierarchy
+  , incomingCalls
+  , outgoingCalls
   ) where
 
 import Control.Applicative.Combinators
@@ -163,7 +166,7 @@ runSessionWithConfig config' serverExe caps rootDir session = do
 --
 -- > (hinRead, hinWrite) <- createPipe
 -- > (houtRead, houtWrite) <- createPipe
--- > 
+-- >
 -- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition
 -- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do
 -- >   -- ...
@@ -656,7 +659,7 @@ getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams
 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
                    -> Position -- ^ The position the term is at.
                    -> Session ([Location] |? [LocationLink])
-getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams 
+getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams
 
 -- | Returns the type definition(s) for the term at the specified position.
 getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.
@@ -746,3 +749,22 @@ getCodeLenses tId = do
 -- @since 0.11.0.0
 getRegisteredCapabilities :: Session [SomeRegistration]
 getRegisteredCapabilities = Map.elems . curDynCaps <$> get
+
+-- | Pass a param and return the response from `prepareCallHierarchy`
+prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem]
+prepareCallHierarchy = resolveRequestWithListResp STextDocumentPrepareCallHierarchy
+
+incomingCalls :: CallHierarchyIncomingCallsParams -> Session [CallHierarchyIncomingCall]
+incomingCalls = resolveRequestWithListResp SCallHierarchyIncomingCalls
+
+outgoingCalls :: CallHierarchyOutgoingCallsParams -> Session [CallHierarchyOutgoingCall]
+outgoingCalls = resolveRequestWithListResp SCallHierarchyOutgoingCalls
+
+-- | Send a request and receive a response with list.
+resolveRequestWithListResp :: (ResponseResult m ~ Maybe (List a))
+               => SClientMethod m -> MessageParams m -> Session [a]
+resolveRequestWithListResp method params = do
+  rsp <- request method params
+  case getResponseResult rsp of
+    Nothing -> pure []
+    Just (List x) -> pure x

lsp-test/test/DummyServer.hs

@@ -16,12 +16,12 @@ import System.Directory
 import System.FilePath
 import System.Process
 import Language.LSP.Types
-  
+
 withDummyServer :: ((Handle, Handle) -> IO ()) -> IO ()
 withDummyServer f = do
   (hinRead, hinWrite) <- createPipe
   (houtRead, houtWrite) <- createPipe
-  
+
   handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
   let definition = ServerDefinition
         { doInitialize = \env _req -> pure $ Right env
@@ -185,4 +185,31 @@ handlers =
                 Nothing
                 Nothing
         resp $ Right $ InR res
+     , requestHandler STextDocumentPrepareCallHierarchy $ \req resp -> do
+        let RequestMessage _ _ _ params = req
+            CallHierarchyPrepareParams _ pos _ = params
+            Position x y = pos
+            item =
+              CallHierarchyItem
+                "foo"
+                SkMethod
+                Nothing
+                Nothing
+                (Uri "")
+                (Range (Position 2 3) (Position 4 5))
+                (Range (Position 2 3) (Position 4 5))
+                Nothing
+        if x == 0 && y == 0
+          then resp $ Right Nothing
+          else resp $ Right $ Just $ List [item]
+     , requestHandler SCallHierarchyIncomingCalls $ \req resp -> do
+        let RequestMessage _ _ _ params = req
+            CallHierarchyIncomingCallsParams _ _ item = params
+        resp $ Right $ Just $
+          List [CallHierarchyIncomingCall item (List [Range (Position 2 3) (Position 4 5)])]
+     , requestHandler SCallHierarchyOutgoingCalls $ \req resp -> do
+        let RequestMessage _ _ _ params = req
+            CallHierarchyOutgoingCallsParams _ _ item = params
+        resp $ Right $ Just $
+          List [CallHierarchyOutgoingCall item (List [Range (Position 4 5) (Position 2 3)])]
     ]

lsp-test/test/Test.hs

@@ -321,10 +321,10 @@ main = hspec $ around withDummyServer $ do
     it "works" $ \(hin, hout) ->
       runSessionWithHandles hin hout (def { ignoreLogNotifications = True }) fullCaps "." $ do
         openDoc "test/data/Format.hs" "haskell"
-        void publishDiagnosticsNotification       
+        void publishDiagnosticsNotification
 
   describe "dynamic capabilities" $ do
-    
+
     it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
       loggingNotification -- initialized log message
 
@@ -373,6 +373,27 @@ main = hspec $ around withDummyServer $ do
       count 0 $ loggingNotification
       void $ anyResponse
 
+  describe "call hierarchy" $ do
+    let workPos = Position 1 0
+        notWorkPos = Position 0 0
+        params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing
+        item = CallHierarchyItem "foo" SkFunction Nothing Nothing (Uri "")
+                                 (Range (Position 1 2) (Position 3 4))
+                                 (Range (Position 1 2) (Position 3 4))
+                                 Nothing
+    it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      rsp <- prepareCallHierarchy (params workPos)
+      liftIO $ head rsp ^. range `shouldBe` Range (Position 2 3) (Position 4 5)
+    it "prepare not works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      rsp <- prepareCallHierarchy (params notWorkPos)
+      liftIO $ rsp `shouldBe` []
+    it "incoming calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      [CallHierarchyIncomingCall _ (List fromRanges)] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item)
+      liftIO $ head fromRanges `shouldBe` Range (Position 2 3) (Position 4 5)
+    it "outgoing calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do
+      [CallHierarchyOutgoingCall _ (List fromRanges)] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item)
+      liftIO $ head fromRanges `shouldBe` Range (Position 4 5) (Position 2 3)
+
 
 didChangeCaps :: ClientCapabilities
 didChangeCaps = def { _workspace = Just workspaceCaps }

lsp-test/test/data/documentSymbolFail/example/Main.hs

@@ -68,6 +68,7 @@ main = do
         (Just (LSP.CodeLensClientCapabilities (Just False)))
         (Just (LSP.DocumentLinkClientCapabilities (Just False)))
         (Just (LSP.RenameClientCapabilities (Just False)))
+        (Just (LSP.CallHierarchyClientCapabilities (Just False)))
 
       initializeParams :: LSP.InitializeParams
       initializeParams = LSP.InitializeParams (Just pid) Nothing Nothing Nothing caps Nothing

lsp-types/lsp-types.cabal

@@ -22,7 +22,8 @@ library
                      , Language.LSP.Types.Lens
                      , Language.LSP.VFS
                      , Data.IxMap
-  other-modules:       Language.LSP.Types.Cancellation
+  other-modules:       Language.LSP.Types.CallHierarchy
+                     , Language.LSP.Types.Cancellation
                      , Language.LSP.Types.ClientCapabilities
                      , Language.LSP.Types.CodeAction
                      , Language.LSP.Types.CodeLens

lsp-types/src/Language/LSP/Types.hs

@@ -1,5 +1,6 @@
 module Language.LSP.Types
-  ( module Language.LSP.Types.Cancellation
+  ( module Language.LSP.Types.CallHierarchy
+  , module Language.LSP.Types.Cancellation
   , module Language.LSP.Types.CodeAction
   , module Language.LSP.Types.CodeLens
   , module Language.LSP.Types.Command
@@ -43,6 +44,7 @@ module Language.LSP.Types
   )
 where
 
+import           Language.LSP.Types.CallHierarchy
 import           Language.LSP.Types.Cancellation
 import           Language.LSP.Types.CodeAction
 import           Language.LSP.Types.CodeLens

lsp-types/src/Language/LSP/Types/CallHierarchy.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+{- | Since LSP 3.16.0 -}
+module Language.LSP.Types.CallHierarchy where
+
+import Data.Aeson.TH
+import Data.Aeson.Types ( Value )
+import Data.Text ( Text )
+
+import Language.LSP.Types.Common
+import Language.LSP.Types.DocumentSymbol
+import Language.LSP.Types.Location
+import Language.LSP.Types.Progress
+import Language.LSP.Types.StaticRegistrationOptions
+import Language.LSP.Types.TextDocument
+import Language.LSP.Types.Uri
+import Language.LSP.Types.Utils
+
+
+data CallHierarchyClientCapabilities =
+  CallHierarchyClientCapabilities
+    { _dynamicRegistration :: Maybe Bool }
+    deriving (Show, Read, Eq)
+deriveJSON lspOptions ''CallHierarchyClientCapabilities
+
+makeExtendingDatatype "CallHierarchyOptions" [''WorkDoneProgressOptions] []
+deriveJSON lspOptions ''CallHierarchyOptions
+
+makeExtendingDatatype "CallHierarchyRegistrationOptions"
+  [ ''TextDocumentRegistrationOptions
+  , ''CallHierarchyOptions
+  , ''StaticRegistrationOptions
+  ]
+  []
+deriveJSON lspOptions ''CallHierarchyRegistrationOptions
+
+makeExtendingDatatype "CallHierarchyPrepareParams"
+  [''TextDocumentPositionParams, ''WorkDoneProgressParams] []
+deriveJSON lspOptions ''CallHierarchyPrepareParams
+
+data CallHierarchyItem =
+  CallHierarchyItem
+    { _name :: Text
+    , _kind :: SymbolKind
+    , _tags :: Maybe (List SymbolTag)
+    -- | More detail for this item, e.g. the signature of a function.
+    , _detail :: Maybe Text
+    , _uri :: Uri
+    , _range :: Range
+    -- | The range that should be selected and revealed when this symbol
+    -- is being picked, e.g. the name of a function. Must be contained by
+    -- the @_range@.
+    , _selectionRange :: Range
+    -- | A data entry field that is preserved between a call hierarchy
+    -- prepare and incoming calls or outgoing calls requests.
+    , _xdata :: Maybe Value
+    }
+    deriving (Show, Read, Eq)
+deriveJSON lspOptions ''CallHierarchyItem
+
+-- -------------------------------------
+
+makeExtendingDatatype "CallHierarchyIncomingCallsParams"
+  [ ''WorkDoneProgressParams
+  , ''PartialResultParams
+  ]
+  [("_item", [t| CallHierarchyItem |])]
+deriveJSON lspOptions ''CallHierarchyIncomingCallsParams
+
+data CallHierarchyIncomingCall =
+  CallHierarchyIncomingCall
+    { -- | The item that makes the call.
+      _from :: CallHierarchyItem
+    -- | The ranges at which the calls appear. This is relative to the caller
+    -- denoted by @_from@.
+    , _fromRanges :: List Range
+    }
+    deriving (Show, Read, Eq)
+deriveJSON lspOptions ''CallHierarchyIncomingCall
+
+-- -------------------------------------
+
+makeExtendingDatatype "CallHierarchyOutgoingCallsParams"
+  [ ''WorkDoneProgressParams
+  , ''PartialResultParams
+  ]
+  [("_item", [t| CallHierarchyItem |])]
+deriveJSON lspOptions ''CallHierarchyOutgoingCallsParams
+
+data CallHierarchyOutgoingCall =
+  CallHierarchyOutgoingCall
+    { -- | The item that is called.
+      _to :: CallHierarchyItem
+    -- | The range at which this item is called. THis is the range relative to
+    -- the caller, e.g the item passed to `callHierarchy/outgoingCalls` request.
+    , _fromRanges :: List Range
+    }
+    deriving (Show, Read, Eq)
+deriveJSON lspOptions ''CallHierarchyOutgoingCall

lsp-types/src/Language/LSP/Types/Capabilities.hs

@@ -51,7 +51,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus
           (Just (ExecuteCommandClientCapabilities dynamicReg))
           (since 3 6 True)
           (since 3 6 True)
-    
+
     resourceOperations = List
       [ ResourceOperationCreate
       , ResourceOperationDelete
@@ -126,6 +126,7 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus
           (Just publishDiagnosticsCapabilities)
           (since 3 10 foldingRangeCapability)
           (since 3 5 (SelectionRangeClientCapabilities dynamicReg))
+          (since 3 16 (CallHierarchyClientCapabilities dynamicReg))
     sync =
       TextDocumentSyncClientCapabilities
         dynamicReg
@@ -266,5 +267,5 @@ capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) (Jus
     since x y a
       | maj >= x && min >= y = Just a
       | otherwise            = Nothing
-    
+
     window = WindowClientCapabilities (since 3 15 True)

lsp-types/src/Language/LSP/Types/ClientCapabilities.hs

@@ -6,6 +6,7 @@ module Language.LSP.Types.ClientCapabilities where
 import           Data.Aeson.TH
 import qualified Data.Aeson as A
 import Data.Default
+import Language.LSP.Types.CallHierarchy
 import Language.LSP.Types.CodeAction
 import Language.LSP.Types.CodeLens
 import Language.LSP.Types.Command
@@ -101,7 +102,7 @@ data TextDocumentClientCapabilities =
     , _onTypeFormatting :: Maybe DocumentOnTypeFormattingClientCapabilities
 
       -- | Capabilities specific to the `textDocument/declaration` request.
-      -- 
+      --
       -- Since LSP 3.14.0
     , _declaration :: Maybe DeclarationClientCapabilities
 
@@ -142,14 +143,18 @@ data TextDocumentClientCapabilities =
       -- | Capabilities specific to the `textDocument/selectionRange` request.
       -- Since LSP 3.15.0
     , _selectionRange :: Maybe SelectionRangeClientCapabilities
+
+      -- | Call hierarchy specific to the `textDocument/prepareCallHierarchy` request.
+      -- Since LSP 3.16.0
+    , _callHierarchy :: Maybe CallHierarchyClientCapabilities
     } deriving (Show, Read, Eq)
 
 deriveJSON lspOptions ''TextDocumentClientCapabilities
 
 instance Default TextDocumentClientCapabilities where
   def = TextDocumentClientCapabilities def def def def def def def def
                                        def def def def def def def def
-                                       def def def def def def
+                                       def def def def def def def
 
 -- ---------------------------------------------------------------------
 

lsp-types/src/Language/LSP/Types/Lens.hs

@@ -12,6 +12,7 @@
 
 module Language.LSP.Types.Lens where
 
+import           Language.LSP.Types.CallHierarchy
 import           Language.LSP.Types.Cancellation
 import           Language.LSP.Types.ClientCapabilities
 import           Language.LSP.Types.CodeAction
@@ -354,3 +355,14 @@ makeFieldsNoPrefix ''SignatureHelp
 
 -- Static registration
 makeFieldsNoPrefix ''StaticRegistrationOptions
+
+-- Call hierarchy
+makeFieldsNoPrefix ''CallHierarchyClientCapabilities
+makeFieldsNoPrefix ''CallHierarchyOptions
+makeFieldsNoPrefix ''CallHierarchyRegistrationOptions
+makeFieldsNoPrefix ''CallHierarchyPrepareParams
+makeFieldsNoPrefix ''CallHierarchyIncomingCallsParams
+makeFieldsNoPrefix ''CallHierarchyIncomingCall
+makeFieldsNoPrefix ''CallHierarchyOutgoingCallsParams
+makeFieldsNoPrefix ''CallHierarchyOutgoingCall
+makeFieldsNoPrefix ''CallHierarchyItem

lsp-types/src/Language/LSP/Types/Message.hs

@@ -17,6 +17,7 @@
 
 module Language.LSP.Types.Message where
 
+import           Language.LSP.Types.CallHierarchy
 import           Language.LSP.Types.Cancellation
 import           Language.LSP.Types.CodeAction
 import           Language.LSP.Types.CodeLens
@@ -120,6 +121,10 @@ type family MessageParams (m :: Method f t) :: Type where
   MessageParams TextDocumentFoldingRange           = FoldingRangeParams
   -- Selection Range
   MessageParams TextDocumentSelectionRange         = SelectionRangeParams
+  -- Call hierarchy
+  MessageParams TextDocumentPrepareCallHierarchy   = CallHierarchyPrepareParams
+  MessageParams CallHierarchyIncomingCalls         = CallHierarchyIncomingCallsParams
+  MessageParams CallHierarchyOutgoingCalls         = CallHierarchyOutgoingCallsParams
 -- Server
     -- Window
   MessageParams WindowShowMessage                  = ShowMessageParams
@@ -193,6 +198,10 @@ type family ResponseResult (m :: Method f Request) :: Type where
   -- FoldingRange
   ResponseResult TextDocumentFoldingRange      = List FoldingRange
   ResponseResult TextDocumentSelectionRange    = List SelectionRange
+  -- Call hierarchy
+  ResponseResult TextDocumentPrepareCallHierarchy = Maybe (List CallHierarchyItem)
+  ResponseResult CallHierarchyIncomingCalls    = Maybe (List CallHierarchyIncomingCall)
+  ResponseResult CallHierarchyOutgoingCalls    = Maybe (List CallHierarchyOutgoingCall)
   -- Custom can be either a notification or a message
 -- Server
   -- Window