From 67ce370791ce37da06271dae4cec8ebed3d4bd92 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 3 Jun 2021 16:39:15 +0800 Subject: [PATCH 01/28] Initialize structure --- cabal.project | 19 +++++ exe/Plugins.hs | 7 ++ haskell-language-server.cabal | 11 +++ hls-plugin-api/src/Ide/Plugin/Config.hs | 78 ++++++++++--------- hls-plugin-api/src/Ide/Types.hs | 11 +++ .../hls-call-hierarchy-plugin.cabal | 38 +++++++++ .../src/Ide/Plugin/CallHierarchy.hs | 19 +++++ 7 files changed, 146 insertions(+), 37 deletions(-) create mode 100644 plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal create mode 100644 plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs diff --git a/cabal.project b/cabal.project index c182e65bf1..3e4cb4762d 100644 --- a/cabal.project +++ b/cabal.project @@ -22,6 +22,7 @@ packages: ./plugins/hls-pragmas-plugin ./plugins/hls-module-name-plugin ./plugins/hls-ormolu-plugin + ./plugins/hls-call-hierarchy-plugin tests: true package * @@ -45,3 +46,21 @@ allow-newer: monoid-extras:base, statestack:base, svg-builder:base + +source-repository-package + type: git + location: https://github.com/July541/lsp.git + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdir: lsp-types + +source-repository-package + type: git + location: https://github.com/July541/lsp.git + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdir: lsp-test + +source-repository-package + type: git + location: https://github.com/July541/lsp.git + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdir: lsp diff --git a/exe/Plugins.hs b/exe/Plugins.hs index d3c809c34c..8b2c3178d6 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -13,6 +13,10 @@ import Ide.Plugin.Example2 as Example2 -- haskell-language-server optional plugins +#if callHierarchy +import Ide.Plugin.CallHierarchy as CallHierarchy +#endif + #if class import Ide.Plugin.Class as Class #endif @@ -117,6 +121,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #if brittany Brittany.descriptor "brittany" : #endif +#if callHierarchy + CallHierarchy.descriptor "callHierarchy": +#endif #if class Class.descriptor "class" : #endif diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f360eaf32f..fb8d2bc332 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -106,6 +106,11 @@ flag class default: True manual: True +flag callHierarchy + description: Enable call hierarchy plugin + default: True + manual: True + flag haddockComments description: Enable haddockComments plugin default: True @@ -193,6 +198,11 @@ common class build-depends: hls-class-plugin ^>= 1.0.0.1 cpp-options: -Dclass +common callHierarchy + if flag(callHierarchy) || flag(all-plugins) + build-depends: hls-call-hierarchy-plugin ^>= 1.0.0.0 + cpp-options: -DcallHierarchy + common haddockComments if flag(haddockComments) || flag(all-plugins) build-depends: hls-haddock-comments-plugin ^>= 1.0.0.1 @@ -274,6 +284,7 @@ executable haskell-language-server import: common-deps -- plugins , example-plugins + , callHierarchy , class , haddockComments , eval diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 150ecaf683..74320887ea 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -121,54 +121,58 @@ instance A.ToJSON Config where -- This provides a regular naming scheme for all plugin config. data PluginConfig = PluginConfig - { plcGlobalOn :: !Bool - , plcCodeActionsOn :: !Bool - , plcCodeLensOn :: !Bool - , plcDiagnosticsOn :: !Bool - , plcHoverOn :: !Bool - , plcSymbolsOn :: !Bool - , plcCompletionOn :: !Bool - , plcRenameOn :: !Bool - , plcConfig :: !A.Object + { plcGlobalOn :: !Bool + , plcCallHierarchyOn :: !Bool + , plcCodeActionsOn :: !Bool + , plcCodeLensOn :: !Bool + , plcDiagnosticsOn :: !Bool + , plcHoverOn :: !Bool + , plcSymbolsOn :: !Bool + , plcCompletionOn :: !Bool + , plcRenameOn :: !Bool + , plcConfig :: !A.Object } deriving (Show,Eq) instance Default PluginConfig where def = PluginConfig - { plcGlobalOn = True - , plcCodeActionsOn = True - , plcCodeLensOn = True - , plcDiagnosticsOn = True - , plcHoverOn = True - , plcSymbolsOn = True - , plcCompletionOn = True - , plcRenameOn = True - , plcConfig = mempty + { plcGlobalOn = True + , plcCallHierarchyOn = True + , plcCodeActionsOn = True + , plcCodeLensOn = True + , plcDiagnosticsOn = True + , plcHoverOn = True + , plcSymbolsOn = True + , plcCompletionOn = True + , plcRenameOn = True + , plcConfig = mempty } instance A.ToJSON PluginConfig where - toJSON (PluginConfig g ca cl d h s c rn cfg) = r + toJSON (PluginConfig g ch ca cl d h s c rn cfg) = r where - r = object [ "globalOn" .= g - , "codeActionsOn" .= ca - , "codeLensOn" .= cl - , "diagnosticsOn" .= d - , "hoverOn" .= h - , "symbolsOn" .= s - , "completionOn" .= c - , "renameOn" .= rn - , "config" .= cfg + r = object [ "globalOn" .= g + , "callHierarchyOn" .= ch + , "codeActionsOn" .= ca + , "codeLensOn" .= cl + , "diagnosticsOn" .= d + , "hoverOn" .= h + , "symbolsOn" .= s + , "completionOn" .= c + , "renameOn" .= rn + , "config" .= cfg ] instance A.FromJSON PluginConfig where parseJSON = A.withObject "PluginConfig" $ \o -> PluginConfig - <$> o .:? "globalOn" .!= plcGlobalOn def - <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def - <*> o .:? "codeLensOn" .!= plcCodeLensOn def - <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ - <*> o .:? "hoverOn" .!= plcHoverOn def - <*> o .:? "symbolsOn" .!= plcSymbolsOn def - <*> o .:? "completionOn" .!= plcCompletionOn def - <*> o .:? "renameOn" .!= plcRenameOn def - <*> o .:? "config" .!= plcConfig def + <$> o .:? "globalOn" .!= plcGlobalOn def + <*> o .:? "callHierarchyOn" .!= plcCallHierarchyOn def + <*> o .:? "codeActionsOn" .!= plcCodeActionsOn def + <*> o .:? "codeLensOn" .!= plcCodeLensOn def + <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ + <*> o .:? "hoverOn" .!= plcHoverOn def + <*> o .:? "symbolsOn" .!= plcSymbolsOn def + <*> o .:? "completionOn" .!= plcCompletionOn def + <*> o .:? "renameOn" .!= plcRenameOn def + <*> o .:? "config" .!= plcConfig def -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 00afd5892d..c09f7f6246 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -246,6 +246,15 @@ instance PluginMethod TextDocumentRangeFormatting where pluginEnabled _ pid conf = (PluginId $ formattingProvider conf) == pid combineResponses _ _ _ _ (x :| _) = x +instance PluginMethod TextDocumentPrepareCallHierarchy where + pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn + +instance PluginMethod CallHierarchyIncomingCalls where + pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn + +instance PluginMethod CallHierarchyOutgoingCalls where + pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn + -- --------------------------------------------------------------------- -- | Methods which have a PluginMethod instance @@ -442,6 +451,8 @@ instance HasTracing InitializeParams instance HasTracing (Maybe InitializedParams) instance HasTracing WorkspaceSymbolParams where traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) +instance HasTracing CallHierarchyIncomingCallsParams +instance HasTracing CallHierarchyOutgoingCallsParams -- --------------------------------------------------------------------- diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal new file mode 100644 index 0000000000..9db03c2a5f --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -0,0 +1,38 @@ +cabal-version: 2.4 +name: hls-call-hierarchy-plugin +version: 1.0.0.0 +synopsis: Call hierarchy plugin for Haskell Language Server +license: Apache-2.0 +-- license-file: LICENSE +author: Lei Zhu +maintainer: julytreee@gmail.com +category: Development +build-type: Simple +extra-source-files: test/testdata/*.hs + +library + exposed-modules: Ide.Plugin.CallHierarchy + hs-source-dirs: src + build-depends: + , base >=4.12 && <5 + , ghcide ^>=1.3 + , hls-plugin-api ^>=1.1 + , lsp + + default-language: Haskell2010 + default-extensions: + DataKinds + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base + , hls-call-hierarchy-plugin + , hls-test-utils + , filepath + , lsp-test + , lsp diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs new file mode 100644 index 0000000000..4a13d843f1 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -0,0 +1,19 @@ +module Ide.Plugin.CallHierarchy where + +import Development.IDE +import Ide.Types +import Language.LSP.Types + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy prepareCallHierarchy + } + +prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy +prepareCallHierarchy = undefined + +incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls +incomingCalls = undefined + +outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls +outgoingCalls = undefined From 4b9a6e73f83069ebb99d24cd13899aa2468cf2dd Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 3 Jun 2021 19:03:15 +0800 Subject: [PATCH 02/28] Add basic tests --- .../hls-call-hierarchy-plugin/test/Main.hs | 48 +++++++++++++++++++ .../test/testdata/A.hs | 10 ++++ .../test/testdata/B.hs | 14 ++++++ .../test/testdata/C.hs | 5 ++ 4 files changed, 77 insertions(+) create mode 100644 plugins/hls-call-hierarchy-plugin/test/Main.hs create mode 100644 plugins/hls-call-hierarchy-plugin/test/testdata/A.hs create mode 100644 plugins/hls-call-hierarchy-plugin/test/testdata/B.hs create mode 100644 plugins/hls-call-hierarchy-plugin/test/testdata/C.hs diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs new file mode 100644 index 0000000000..ac8c8e9738 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Lens +import Ide.Plugin.CallHierarchy +import qualified Language.LSP.Test as Test +import qualified Language.LSP.Types.Lens as L +import System.FilePath +import Test.Hls + +plugin :: PluginDescriptor IdeState +plugin = descriptor "callHierarchy" + +main :: IO () +main = defaultTestRunner $ testGroup "Call Hierarchy" [prepareCallHierarchyTests] + + +prepareCallHierarchyTests :: TestTree +prepareCallHierarchyTests = + testGroup + "Prepare Call Hierarchy" + [ testCase "simple call hierarchy" $ do + runSessionWithServer plugin testDataDir $ do + doc <- openDoc "B.hs" "haskell" + [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 11 0) + let expectedRange = Range (Position 11 0) (Position 11 1) + expected = CallHierarchyItem "a" SkFunction Nothing Nothing (doc ^. L.uri) expectedRange expectedRange Nothing + liftIO $ item @?= expected + , testCase "typeclass" $ do + runSessionWithServer plugin testDataDir $ do + doc <- openDoc "B.hs" "haskell" + [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 9 0) + let expectedRange = Range (Position 9 0) (Position 9 1) + expected = CallHierarchyItem "g" SkFunction Nothing Nothing (doc ^. L.uri) expectedRange expectedRange Nothing + liftIO $ item @?= expected + ] + +testDataDir :: FilePath +testDataDir = "test" "testdata" + +mkPrepareCallHierarchyParam :: TextDocumentIdentifier -> Int -> Int -> CallHierarchyPrepareParams +mkPrepareCallHierarchyParam doc x y = CallHierarchyPrepareParams doc (Position x y) Nothing + +mkIncomingCallsParam :: CallHierarchyItem -> CallHierarchyIncomingCallsParams +mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing + +mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams +mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs new file mode 100644 index 0000000000..36af15f5a2 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs @@ -0,0 +1,10 @@ +module A where +import B +import C +foo1 = B.a + C.a +foo2 = C.c + c +foo3 = foo1 + foo2 +foo4 :: Bool +foo4 = g +foo5 :: Integer +foo5 = g \ No newline at end of file diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs new file mode 100644 index 0000000000..34c92bc8e6 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs @@ -0,0 +1,14 @@ +module B (a, b, F(g)) where + +class F a where + g :: a + +instance F Integer where + g = 3 + +instance F Bool where + g = True + +a = 3 +b = 4 +c = 5 \ No newline at end of file diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs new file mode 100644 index 0000000000..0c9a39b6d7 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs @@ -0,0 +1,5 @@ +module C where + +a = 3 +b = 4 +c = 5 \ No newline at end of file From f8cfe989c74c6defb5226b5cd6b2c47a39fe2396 Mon Sep 17 00:00:00 2001 From: July541 Date: Wed, 9 Jun 2021 13:57:58 +0800 Subject: [PATCH 03/28] prepareCallHierarchy --- .../hls-call-hierarchy-plugin.cabal | 6 ++ .../src/Ide/Plugin/CallHierarchy.hs | 69 ++++++++++++++++++- 2 files changed, 74 insertions(+), 1 deletion(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 9db03c2a5f..629d7df44c 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -18,6 +18,11 @@ library , ghcide ^>=1.3 , hls-plugin-api ^>=1.1 , lsp + , containers + , hiedb + , ghc + , lens + , text default-language: Haskell2010 default-extensions: @@ -36,3 +41,4 @@ test-suite tests , filepath , lsp-test , lsp + , lens diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 4a13d843f1..3c8552f6f0 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -1,8 +1,25 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.CallHierarchy where +import Control.Lens ((^.)) +import Control.Monad.IO.Class +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.Spans.AtPoint +import HieDb (searchDef, type (:.) ((:.))) import Ide.Types import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L +import Name descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -10,10 +27,60 @@ descriptor plId = (defaultPluginDescriptor plId) } prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy -prepareCallHierarchy = undefined +prepareCallHierarchy state pluginId param + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = + liftIO $ prepareCallHierarchyItem state nfp pos >>= + \case + Just item -> pure $ Right $ Just $ List item + Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" + | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri + where + uri = param ^. (L.textDocument . L.uri) + pos = param ^. L.position + + incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls incomingCalls = undefined outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls outgoingCalls = undefined + +prepareCallHierarchyItem :: IdeState -> NormalizedFilePath -> Position -> IO (Maybe [CallHierarchyItem]) +prepareCallHierarchyItem state filepath pos = do + let ShakeExtras{hiedb} = shakeExtras state + runAction "CallHierarchy.mkCallHierarchyItem" state (use GetHieAst filepath) >>= + \case + Nothing -> pure Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ + pointCommand hf pos + (\ast -> ((M.keys . nodeIdentifiers . nodeInfo) ast, nodeSpan ast)) of + Just res -> pure $ Just $ nub $ map (\x -> construct x (snd res)) (fst res) + _ -> pure Nothing + where + getSymbolKind occName + | isVarOcc occName = SkVariable + | isDataOcc occName = SkConstructor + | isTvOcc occName = SkStruct + | otherwise = SkUnknown 27 -- avoid duplication + + construct :: Identifier -> Span -> CallHierarchyItem + construct identifer span = case identifer of + Left modName -> mkCallHierarchyItem (moduleNameString modName) SkModule span + Right name -> let occName = nameOccName name + in mkCallHierarchyItem (occNameString occName) (getSymbolKind occName) span + + mkCallHierarchyItem :: String -> SymbolKind -> Span -> CallHierarchyItem + mkCallHierarchyItem name kind span = + CallHierarchyItem + (T.pack name) + kind + Nothing + Nothing + (fromNormalizedUri $ normalizedFilePathToUri filepath) + (realSrcSpanToRange span) + (realSrcSpanToRange span) + Nothing + + From 118acd759eaf5c6f5d77fff9f297b8afc9ab9f02 Mon Sep 17 00:00:00 2001 From: July541 Date: Sat, 12 Jun 2021 20:04:03 +0800 Subject: [PATCH 04/28] Add prepare call hierarchy tests --- .../hls-call-hierarchy-plugin.cabal | 1 + .../hls-call-hierarchy-plugin/test/Main.hs | 168 ++++++++++++++++-- 2 files changed, 154 insertions(+), 15 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 629d7df44c..5b31a2afdc 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -42,3 +42,4 @@ test-suite tests , lsp-test , lsp , lens + , text diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index ac8c8e9738..20552a3538 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Lens +import qualified Data.Text as T import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test import qualified Language.LSP.Types.Lens as L @@ -14,27 +16,163 @@ plugin = descriptor "callHierarchy" main :: IO () main = defaultTestRunner $ testGroup "Call Hierarchy" [prepareCallHierarchyTests] - prepareCallHierarchyTests :: TestTree prepareCallHierarchyTests = testGroup "Prepare Call Hierarchy" - [ testCase "simple call hierarchy" $ do - runSessionWithServer plugin testDataDir $ do - doc <- openDoc "B.hs" "haskell" - [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 11 0) - let expectedRange = Range (Position 11 0) (Position 11 1) - expected = CallHierarchyItem "a" SkFunction Nothing Nothing (doc ^. L.uri) expectedRange expectedRange Nothing - liftIO $ item @?= expected - , testCase "typeclass" $ do - runSessionWithServer plugin testDataDir $ do - doc <- openDoc "B.hs" "haskell" - [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 9 0) - let expectedRange = Range (Position 9 0) (Position 9 1) - expected = CallHierarchyItem "g" SkFunction Nothing Nothing (doc ^. L.uri) expectedRange expectedRange Nothing - liftIO $ item @?= expected + [ testCase "variable" $ do + let contents = T.unlines ["a=3"] + range = mkRange 0 0 0 3 + selRange = mkRange 0 0 0 1 + expected = mkCallHierarchyItem "a" SkVariable range selRange + oneCaseWithCreate contents 0 0 expected + , testCase "function" $ do + let contents = T.unlines ["a=(+)"] + range = mkRange 0 0 0 5 + selRange = mkRange 0 0 0 1 + expected = mkCallHierarchyItem "a" SkFunction range selRange + oneCaseWithCreate contents 0 0 expected + , testCase "datatype" $ do + let contents = T.unlines ["data A=A"] + range = mkRange 0 5 0 6 + selRange = mkRange 0 5 0 6 + expected = mkCallHierarchyItem "A" SkStruct range selRange + oneCaseWithCreate contents 0 5 expected + , testCase "data constructor" $ do + let contents = T.unlines ["data A=A"] + range = mkRange 0 7 0 8 + selRange = mkRange 0 7 0 8 + expected = mkCallHierarchyItem "A" SkConstructor range selRange + oneCaseWithCreate contents 0 7 expected + , testCase "record" $ do + let contents = T.unlines ["data A=A{a::Int}"] + range = mkRange 0 9 0 14 + selRange = mkRange 0 9 0 10 + expected = mkCallHierarchyItem "a" SkField range selRange + oneCaseWithCreate contents 0 9 expected + , testCase "type operator" $ do + let contents = T.unlines ["{-# LANGUAGE TypeOperator -#}", "type (><)=Maybe"] + range = mkRange 1 6 1 8 + selRange = mkRange 1 6 1 8 + expected = mkCallHierarchyItem "(><)" SkStruct range selRange + oneCaseWithCreate contents 1 6 expected + , testCase "type class" $ do + let contents = T.unlines ["class A a where a :: a -> Int"] + range = mkRange 0 6 0 7 + selRange = mkRange 0 6 0 7 + expected = mkCallHierarchyItem "A" SkInterface range selRange + oneCaseWithCreate contents 0 6 expected + , testCase "type class method" $ do + let contents = T.unlines ["class A a where a :: a -> Int"] + range = mkRange 0 16 0 29 + selRange = mkRange 0 16 0 17 + expected = mkCallHierarchyItem "a" SkMethod range selRange + oneCaseWithCreate contents 0 16 expected + , testCase "type class instance" $ do -- TODO: add details to prevent ambiguous + let contents = T.unlines ["class A a where", "instance A () where"] + range = mkRange 1 9 1 10 + selRange = mkRange 1 9 1 10 + expected = mkCallHierarchyItem "A" SkInterface range selRange + oneCaseWithCreate contents 1 9 expected + , testGroup "type family" + [ testCase "1" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"] + range = mkRange 1 12 1 13 + selRange = range + expected = mkCallHierarchyItem "A" SkFunction range selRange + oneCaseWithCreate contents 1 12 expected + , testCase "2" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"] + range = mkRange 1 12 1 15 + selRange = range + expected = mkCallHierarchyItem "A a" SkFunction range selRange + oneCaseWithCreate contents 1 12 expected + ] + , testCase "type family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + range = mkRange 2 14 2 17 + selRange = range + expected = mkCallHierarchyItem "A ()" SkInterface range selRange + oneCaseWithCreate contents 2 14 expected + , testGroup "data family" + [ testCase "1" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] + range = mkRange 1 12 1 13 + selRange = range + expected = mkCallHierarchyItem "A" SkFunction range selRange + oneCaseWithCreate contents 1 12 expected + , testCase "2" $ do + let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] + range = mkRange 1 12 1 15 + selRange = range + expected = mkCallHierarchyItem "A a" SkFunction range selRange + oneCaseWithCreate contents 1 12 expected + ] + , testCase "data family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "data family A a" + , "data instance A () = A()" + ] + range = mkRange 2 14 2 17 + selRange = range + expected = mkCallHierarchyItem "A ()" SkInterface range selRange + oneCaseWithCreate contents 2 14 expected + , testCase "pattern" $ do + let contents = T.unlines ["Just x = Just 3"] + range = mkRange 0 5 0 6 + selRange = range + expected = mkCallHierarchyItem "x" SkVariable range selRange + oneCaseWithCreate contents 0 5 expected + , testCase "pattern with type signature" $ do + let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"] + range = mkRange 1 0 1 7 + selRange = mkRange 1 0 1 1 + expected = mkCallHierarchyItem "a" SkFunction range selRange + oneCaseWithCreate contents 1 0 expected + , testCase "type synonym" $ do + let contents = T.unlines ["type A=Bool"] + range = mkRange 0 5 0 6 + selRange = range + expected = mkCallHierarchyItem "A" SkTypeParameter range selRange + oneCaseWithCreate contents 0 5 expected + , testCase "GADT" $ do + let contents = T.unlines + [ "{-# LANGUAGE GADTs #-}" + , "data A where A :: Int -> A" + ] + range = mkRange 1 13 1 26 + selRange = mkRange 1 13 1 14 + expected = mkCallHierarchyItem "A" SkConstructor range selRange + oneCaseWithCreate contents 1 13 expected ] +oneCaseWithOpen :: FilePath -> Int -> Int -> CallHierarchyItem -> Assertion +oneCaseWithOpen filename queryX queryY expected = + runSessionWithServer plugin testDataDir $ do + doc <- openDoc filename "haskell" + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= + \case + [item] -> liftIO $ item @?= expected + _ -> liftIO $ assertFailure "Not one element" + +oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion +oneCaseWithCreate contents queryX queryY expected = + runSessionWithServer plugin testDataDir $ do + doc <- createDoc "A.hs" "haskell" contents + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= + \case + [item] -> liftIO $ item @?= expected (doc ^. L.uri) + _ -> liftIO $ assertFailure "Not one element" + +mkCallHierarchyItem :: T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem +mkCallHierarchyItem name kind range selRange uri = + CallHierarchyItem name kind Nothing Nothing uri range selRange Nothing + testDataDir :: FilePath testDataDir = "test" "testdata" From 7a8979d7576e1e5d39e2f32f09511b1090925881 Mon Sep 17 00:00:00 2001 From: July541 Date: Mon, 21 Jun 2021 20:15:41 +0800 Subject: [PATCH 05/28] Prepare call hierarchy support --- .../hls-call-hierarchy-plugin.cabal | 2 +- .../src/Ide/Plugin/CallHierarchy.hs | 108 +++++++++++++----- .../hls-call-hierarchy-plugin/test/Main.hs | 96 ++++++++-------- 3 files changed, 127 insertions(+), 79 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 5b31a2afdc..484db32603 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -15,7 +15,7 @@ library hs-source-dirs: src build-depends: , base >=4.12 && <5 - , ghcide ^>=1.3 + , ghcide >=1.2 && <1.5 , hls-plugin-api ^>=1.1 , lsp , containers diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 3c8552f6f0..801bcb11a4 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -7,9 +7,9 @@ module Ide.Plugin.CallHierarchy where import Control.Lens ((^.)) import Control.Monad.IO.Class -import Data.List import qualified Data.Map as M import Data.Maybe +import qualified Data.Set as S import qualified Data.Text as T import Development.IDE import Development.IDE.Core.Shake @@ -30,16 +30,14 @@ prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHier prepareCallHierarchy state pluginId param | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = liftIO $ prepareCallHierarchyItem state nfp pos >>= - \case - Just item -> pure $ Right $ Just $ List item - Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" + \case + Just items -> pure $ Right $ Just $ List items + Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri where uri = param ^. (L.textDocument . L.uri) pos = param ^. L.position - - incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls incomingCalls = undefined @@ -48,31 +46,83 @@ outgoingCalls = undefined prepareCallHierarchyItem :: IdeState -> NormalizedFilePath -> Position -> IO (Maybe [CallHierarchyItem]) prepareCallHierarchyItem state filepath pos = do - let ShakeExtras{hiedb} = shakeExtras state - runAction "CallHierarchy.mkCallHierarchyItem" state (use GetHieAst filepath) >>= + runAction "CallHierarchy.prepareCallHierarchyItem" state (use GetHieAst filepath) >>= \case Nothing -> pure Nothing Just (HAR _ hf _ _ _) -> do - case listToMaybe $ - pointCommand hf pos - (\ast -> ((M.keys . nodeIdentifiers . nodeInfo) ast, nodeSpan ast)) of - Just res -> pure $ Just $ nub $ map (\x -> construct x (snd res)) (fst res) - _ -> pure Nothing + case listToMaybe $ pointCommand hf pos extract of + Just res -> pure $ Just $ mapMaybe construct res + _ -> pure Nothing where - getSymbolKind occName - | isVarOcc occName = SkVariable - | isDataOcc occName = SkConstructor - | isTvOcc occName = SkStruct - | otherwise = SkUnknown 27 -- avoid duplication - - construct :: Identifier -> Span -> CallHierarchyItem - construct identifer span = case identifer of - Left modName -> mkCallHierarchyItem (moduleNameString modName) SkModule span - Right name -> let occName = nameOccName name - in mkCallHierarchyItem (occNameString occName) (getSymbolKind occName) span - - mkCallHierarchyItem :: String -> SymbolKind -> Span -> CallHierarchyItem - mkCallHierarchyItem name kind span = + + extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)] + extract ast = let span = nodeSpan ast + infos = M.toList $ M.map identInfo (nodeIdentifiers $ nodeInfo ast) + in [ (ident, contexts, span) | (ident, contexts) <- infos ] + + identifierName :: Identifier -> String + identifierName = \case + Left modName -> moduleNameString modName + Right name -> occNameString $ nameOccName name + + recFieldInfo :: S.Set ContextInfo -> Maybe ContextInfo + recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] + + declInfo :: S.Set ContextInfo -> Maybe ContextInfo + declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] + + valBindInfo :: S.Set ContextInfo -> Maybe ContextInfo + valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] + + classTyDeclInfo :: S.Set ContextInfo -> Maybe ContextInfo + classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- S.toList ctxs] + + useInfo :: S.Set ContextInfo -> Maybe ContextInfo + useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] + + patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo + patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs] + + construct :: (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem + construct (ident, contexts, ssp) + | Just (RecField RecFieldDecl _) <- recFieldInfo contexts + -- ignored type span + = Just $ mkCallHierarchyItem name SkField ssp ssp + + | Just ctx <- valBindInfo contexts + = Just $ case ctx of + ValBind _ _ span -> mkCallHierarchyItem name SkFunction (renderSpan span) ssp + _ -> mkCallHierarchyItem name skUnknown ssp ssp + + | Just ctx <- declInfo contexts + = Just $ case ctx of + -- TODO: sort in alphabetical order + Decl DataDec span -> mkCallHierarchyItem name SkStruct (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem name SkConstructor (renderSpan span) ssp + Decl SynDec span -> mkCallHierarchyItem name SkTypeParameter (renderSpan span) ssp + Decl ClassDec span -> mkCallHierarchyItem name SkInterface (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem name SkFunction (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem name SkInterface (renderSpan span) ssp + _ -> mkCallHierarchyItem name skUnknown ssp ssp + + | Just (ClassTyDecl span) <- classTyDeclInfo contexts + = Just $ mkCallHierarchyItem name SkMethod (renderSpan span) ssp + + | Just (PatternBind _ _ span) <- patternBindInfo contexts + = Just $ mkCallHierarchyItem name SkFunction (renderSpan span) ssp + + | Just Use <- useInfo contexts + = Just $ mkCallHierarchyItem name SkInterface ssp ssp + + | otherwise = Nothing + where + name = identifierName ident + renderSpan = \case Just span -> span + _ -> ssp + skUnknown = SkUnknown 27 + + mkCallHierarchyItem :: String -> SymbolKind -> Span -> Span -> CallHierarchyItem + mkCallHierarchyItem name kind span selSpan = CallHierarchyItem (T.pack name) kind @@ -80,7 +130,5 @@ prepareCallHierarchyItem state filepath pos = do Nothing (fromNormalizedUri $ normalizedFilePathToUri filepath) (realSrcSpanToRange span) - (realSrcSpanToRange span) + (realSrcSpanToRange selSpan) Nothing - - diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 20552a3538..9f97adaee3 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -24,7 +24,7 @@ prepareCallHierarchyTests = let contents = T.unlines ["a=3"] range = mkRange 0 0 0 3 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItem "a" SkVariable range selRange + expected = mkCallHierarchyItem "a" SkFunction range selRange oneCaseWithCreate contents 0 0 expected , testCase "function" $ do let contents = T.unlines ["a=(+)"] @@ -34,7 +34,7 @@ prepareCallHierarchyTests = oneCaseWithCreate contents 0 0 expected , testCase "datatype" $ do let contents = T.unlines ["data A=A"] - range = mkRange 0 5 0 6 + range = mkRange 0 0 0 8 selRange = mkRange 0 5 0 6 expected = mkCallHierarchyItem "A" SkStruct range selRange oneCaseWithCreate contents 0 5 expected @@ -46,19 +46,19 @@ prepareCallHierarchyTests = oneCaseWithCreate contents 0 7 expected , testCase "record" $ do let contents = T.unlines ["data A=A{a::Int}"] - range = mkRange 0 9 0 14 + range = mkRange 0 9 0 10 selRange = mkRange 0 9 0 10 expected = mkCallHierarchyItem "a" SkField range selRange oneCaseWithCreate contents 0 9 expected , testCase "type operator" $ do - let contents = T.unlines ["{-# LANGUAGE TypeOperator -#}", "type (><)=Maybe"] - range = mkRange 1 6 1 8 - selRange = mkRange 1 6 1 8 - expected = mkCallHierarchyItem "(><)" SkStruct range selRange - oneCaseWithCreate contents 1 6 expected + let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] + range = mkRange 1 0 1 15 + selRange = mkRange 1 5 1 9 + expected = mkCallHierarchyItem "><" SkTypeParameter range selRange + oneCaseWithCreate contents 1 5 expected , testCase "type class" $ do let contents = T.unlines ["class A a where a :: a -> Int"] - range = mkRange 0 6 0 7 + range = mkRange 0 0 0 29 selRange = mkRange 0 6 0 7 expected = mkCallHierarchyItem "A" SkInterface range selRange oneCaseWithCreate contents 0 6 expected @@ -77,15 +77,15 @@ prepareCallHierarchyTests = , testGroup "type family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"] - range = mkRange 1 12 1 13 - selRange = range + range = mkRange 1 0 1 13 + selRange = mkRange 1 12 1 13 expected = mkCallHierarchyItem "A" SkFunction range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"] - range = mkRange 1 12 1 15 - selRange = range - expected = mkCallHierarchyItem "A a" SkFunction range selRange + range = mkRange 1 0 1 15 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItem "A" SkFunction range selRange oneCaseWithCreate contents 1 12 expected ] , testCase "type family instance" $ do @@ -94,50 +94,50 @@ prepareCallHierarchyTests = , "type family A a" , "type instance A () = ()" ] - range = mkRange 2 14 2 17 - selRange = range - expected = mkCallHierarchyItem "A ()" SkInterface range selRange - oneCaseWithCreate contents 2 14 expected - , testGroup "data family" - [ testCase "1" $ do - let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] - range = mkRange 1 12 1 13 - selRange = range - expected = mkCallHierarchyItem "A" SkFunction range selRange - oneCaseWithCreate contents 1 12 expected - , testCase "2" $ do - let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] - range = mkRange 1 12 1 15 - selRange = range - expected = mkCallHierarchyItem "A a" SkFunction range selRange - oneCaseWithCreate contents 1 12 expected - ] - , testCase "data family instance" $ do - let contents = T.unlines - [ "{-# LANGUAGE TypeFamilies #-}" - , "data family A a" - , "data instance A () = A()" - ] - range = mkRange 2 14 2 17 - selRange = range - expected = mkCallHierarchyItem "A ()" SkInterface range selRange + range = mkRange 2 14 2 23 + selRange = mkRange 2 14 2 15 + expected = mkCallHierarchyItem "A" SkInterface range selRange oneCaseWithCreate contents 2 14 expected + -- , testGroup "data family" + -- [ testCase "1" $ do + -- let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] + -- range = mkRange 1 0 1 13 + -- selRange = mkRange 1 12 1 13 + -- expected = mkCallHierarchyItem "A" SkFunction range selRange + -- oneCaseWithCreate contents 1 12 expected + -- , testCase "2" $ do + -- let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] + -- range = mkRange 1 0 1 15 + -- selRange = mkRange 1 12 1 13 + -- expected = mkCallHierarchyItem "A" SkFunction range selRange + -- oneCaseWithCreate contents 1 12 expected + -- ] + -- , testCase "data family instance" $ do + -- let contents = T.unlines + -- [ "{-# LANGUAGE TypeFamilies #-}" + -- , "data family A a" + -- , "data instance A () = A()" + -- ] + -- range = mkRange 2 0 2 24 + -- selRange = mkRange 2 14 2 15 + -- expected = mkCallHierarchyItem "A" SkInterface range selRange + -- oneCaseWithCreate contents 2 14 expected , testCase "pattern" $ do let contents = T.unlines ["Just x = Just 3"] - range = mkRange 0 5 0 6 - selRange = range - expected = mkCallHierarchyItem "x" SkVariable range selRange + range = mkRange 0 0 0 15 + selRange = mkRange 0 5 0 6 + expected = mkCallHierarchyItem "x" SkFunction range selRange oneCaseWithCreate contents 0 5 expected , testCase "pattern with type signature" $ do let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"] - range = mkRange 1 0 1 7 + range = mkRange 1 0 1 12 selRange = mkRange 1 0 1 1 expected = mkCallHierarchyItem "a" SkFunction range selRange oneCaseWithCreate contents 1 0 expected , testCase "type synonym" $ do let contents = T.unlines ["type A=Bool"] - range = mkRange 0 5 0 6 - selRange = range + range = mkRange 0 0 0 11 + selRange = mkRange 0 5 0 6 expected = mkCallHierarchyItem "A" SkTypeParameter range selRange oneCaseWithCreate contents 0 5 expected , testCase "GADT" $ do @@ -167,7 +167,7 @@ oneCaseWithCreate contents queryX queryY expected = Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> liftIO $ item @?= expected (doc ^. L.uri) - _ -> liftIO $ assertFailure "Not one element" + res -> liftIO $ assertFailure "Not one element" mkCallHierarchyItem :: T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem mkCallHierarchyItem name kind range selRange uri = From 3c809f0d34a086ad26d1eaecb1a36a3b06f3ea8b Mon Sep 17 00:00:00 2001 From: July541 Date: Tue, 6 Jul 2021 23:03:48 +0800 Subject: [PATCH 06/28] add outgoing calls --- .../hls-call-hierarchy-plugin.cabal | 10 + .../src/Ide/Plugin/CallHierarchy.hs | 131 +-------- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 255 ++++++++++++++++++ .../src/Ide/Plugin/CallHierarchy/Query.hs | 40 +++ .../src/Ide/Plugin/CallHierarchy/Types.hs | 37 +++ 5 files changed, 345 insertions(+), 128 deletions(-) create mode 100644 plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs create mode 100644 plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs create mode 100644 plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 484db32603..b5e07a054a 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -12,6 +12,10 @@ extra-source-files: test/testdata/*.hs library exposed-modules: Ide.Plugin.CallHierarchy + other-modules: + Ide.Plugin.CallHierarchy.Query + Ide.Plugin.CallHierarchy.Types + Ide.Plugin.CallHierarchy.Internal hs-source-dirs: src build-depends: , base >=4.12 && <5 @@ -23,6 +27,12 @@ library , ghc , lens , text + , aeson + , mtl + , transformers + , unordered-containers + , sqlite-simple + , bytestring default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 801bcb11a4..5747fcb6da 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -1,134 +1,9 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.CallHierarchy where -import Control.Lens ((^.)) -import Control.Monad.IO.Class -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Set as S -import qualified Data.Text as T -import Development.IDE -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat -import Development.IDE.Spans.AtPoint -import HieDb (searchDef, type (:.) ((:.))) -import Ide.Types -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L -import Name +import qualified Ide.Plugin.CallHierarchy.Internal as X descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy prepareCallHierarchy + { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy + <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls } - -prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy -prepareCallHierarchy state pluginId param - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = - liftIO $ prepareCallHierarchyItem state nfp pos >>= - \case - Just items -> pure $ Right $ Just $ List items - Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" - | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri - where - uri = param ^. (L.textDocument . L.uri) - pos = param ^. L.position - -incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls -incomingCalls = undefined - -outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls -outgoingCalls = undefined - -prepareCallHierarchyItem :: IdeState -> NormalizedFilePath -> Position -> IO (Maybe [CallHierarchyItem]) -prepareCallHierarchyItem state filepath pos = do - runAction "CallHierarchy.prepareCallHierarchyItem" state (use GetHieAst filepath) >>= - \case - Nothing -> pure Nothing - Just (HAR _ hf _ _ _) -> do - case listToMaybe $ pointCommand hf pos extract of - Just res -> pure $ Just $ mapMaybe construct res - _ -> pure Nothing - where - - extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)] - extract ast = let span = nodeSpan ast - infos = M.toList $ M.map identInfo (nodeIdentifiers $ nodeInfo ast) - in [ (ident, contexts, span) | (ident, contexts) <- infos ] - - identifierName :: Identifier -> String - identifierName = \case - Left modName -> moduleNameString modName - Right name -> occNameString $ nameOccName name - - recFieldInfo :: S.Set ContextInfo -> Maybe ContextInfo - recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] - - declInfo :: S.Set ContextInfo -> Maybe ContextInfo - declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] - - valBindInfo :: S.Set ContextInfo -> Maybe ContextInfo - valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] - - classTyDeclInfo :: S.Set ContextInfo -> Maybe ContextInfo - classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- S.toList ctxs] - - useInfo :: S.Set ContextInfo -> Maybe ContextInfo - useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] - - patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo - patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs] - - construct :: (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem - construct (ident, contexts, ssp) - | Just (RecField RecFieldDecl _) <- recFieldInfo contexts - -- ignored type span - = Just $ mkCallHierarchyItem name SkField ssp ssp - - | Just ctx <- valBindInfo contexts - = Just $ case ctx of - ValBind _ _ span -> mkCallHierarchyItem name SkFunction (renderSpan span) ssp - _ -> mkCallHierarchyItem name skUnknown ssp ssp - - | Just ctx <- declInfo contexts - = Just $ case ctx of - -- TODO: sort in alphabetical order - Decl DataDec span -> mkCallHierarchyItem name SkStruct (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem name SkConstructor (renderSpan span) ssp - Decl SynDec span -> mkCallHierarchyItem name SkTypeParameter (renderSpan span) ssp - Decl ClassDec span -> mkCallHierarchyItem name SkInterface (renderSpan span) ssp - Decl FamDec span -> mkCallHierarchyItem name SkFunction (renderSpan span) ssp - Decl InstDec span -> mkCallHierarchyItem name SkInterface (renderSpan span) ssp - _ -> mkCallHierarchyItem name skUnknown ssp ssp - - | Just (ClassTyDecl span) <- classTyDeclInfo contexts - = Just $ mkCallHierarchyItem name SkMethod (renderSpan span) ssp - - | Just (PatternBind _ _ span) <- patternBindInfo contexts - = Just $ mkCallHierarchyItem name SkFunction (renderSpan span) ssp - - | Just Use <- useInfo contexts - = Just $ mkCallHierarchyItem name SkInterface ssp ssp - - | otherwise = Nothing - where - name = identifierName ident - renderSpan = \case Just span -> span - _ -> ssp - skUnknown = SkUnknown 27 - - mkCallHierarchyItem :: String -> SymbolKind -> Span -> Span -> CallHierarchyItem - mkCallHierarchyItem name kind span selSpan = - CallHierarchyItem - (T.pack name) - kind - Nothing - Nothing - (fromNormalizedUri $ normalizedFilePathToUri filepath) - (realSrcSpanToRange span) - (realSrcSpanToRange selSpan) - Nothing diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs new file mode 100644 index 0000000000..3fe64aa367 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ide.Plugin.CallHierarchy.Internal where + +import Control.Lens (Field1 (_1), Field3 (_3), (^.)) +import Control.Monad.IO.Class +import Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.Spans.AtPoint +import HieDb (Symbol (Symbol)) +import qualified Ide.Plugin.CallHierarchy.Query as Q +import Ide.Plugin.CallHierarchy.Types +import Ide.Types +import Language.LSP.Types +import qualified Language.LSP.Types.Lens as L +import Name +import Text.Read (readMaybe) + +prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy +prepareCallHierarchy state pluginId param + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = + liftIO (runAction "" state (prepareCallHierarchyItem state nfp pos)) >>= + \case + Just items -> pure $ Right $ Just $ List items + Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" + | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri + where + uri = param ^. (L.textDocument . L.uri) + pos = param ^. L.position + +prepareCallHierarchyItem :: IdeState -> NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +prepareCallHierarchyItem state nfp pos = do + fs <- getFilesOfInterestUntracked + if nfp `elem` HM.keys fs + then constructFromAst state nfp pos + else constructFromAst state nfp pos + +constructFromHieDb :: IdeState -> NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +constructFromHieDb state nfp pos = undefined + +constructFromAst :: IdeState -> NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +constructFromAst state nfp pos = + use GetHieAst nfp >>= + \case + Nothing -> pure Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ pointCommand hf pos extract of + Just res -> pure $ Just $ mapMaybe (construct nfp) res + Nothing -> pure Nothing + +extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)] +extract ast = let span = nodeSpan ast + infos = M.toList $ M.map identInfo (nodeIdentifiers $ nodeInfo ast) + in [ (ident, contexts, span) | (ident, contexts) <- infos ] + +identifierName :: Identifier -> String +identifierName = \case + Left modName -> moduleNameString modName + Right name -> occNameString $ nameOccName name + +recFieldInfo :: S.Set ContextInfo -> Maybe ContextInfo +recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] + +declInfo :: S.Set ContextInfo -> Maybe ContextInfo +declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] + +valBindInfo :: S.Set ContextInfo -> Maybe ContextInfo +valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] + +classTyDeclInfo :: S.Set ContextInfo -> Maybe ContextInfo +classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- S.toList ctxs] + +useInfo :: S.Set ContextInfo -> Maybe ContextInfo +useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] + +patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo +patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs] + +construct :: NormalizedFilePath -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem +construct nfp (ident, contexts, ssp) + | Just (RecField RecFieldDecl _) <- recFieldInfo contexts + -- ignored type span + = Just $ mkCallHierarchyItem' ident SkField ssp ssp + + | Just ctx <- valBindInfo contexts + = Just $ case ctx of + ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + _ -> mkCallHierarchyItem' ident skUnknown ssp ssp + + | Just ctx <- declInfo contexts + = Just $ case ctx of + -- TODO: sort in alphabetical order + Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp + Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp + Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + _ -> mkCallHierarchyItem' ident skUnknown ssp ssp + + | Just (ClassTyDecl span) <- classTyDeclInfo contexts + = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) ssp + + | Just (PatternBind _ _ span) <- patternBindInfo contexts + = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + + | Just Use <- useInfo contexts + = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp + + | otherwise = Nothing + where + renderSpan = \case Just span -> span + _ -> ssp + skUnknown = SkUnknown 27 + mkCallHierarchyItem' = mkCallHierarchyItem nfp + +mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem +mkCallHierarchyItem nfp ident kind span selSpan = + CallHierarchyItem + (T.pack $ identifierName ident) + kind + Nothing + (T.pack . show <$> mkSymbol ident) + (fromNormalizedUri $ normalizedFilePathToUri nfp) + (realSrcSpanToRange span) + (realSrcSpanToRange selSpan) + (toJSON . show <$> mkSymbol ident) + +mkSymbol :: Identifier -> Maybe Symbol +mkSymbol = \case + Left _ -> Nothing + Right name -> Just $ Symbol (occName name) (nameModule name) + +incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls +incomingCalls state pluginId param = do + liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls state (param ^. L.item) >>= + \case + Just x -> pure $ Right $ Just $ List x + Nothing -> pure $ Left $ responseError "incoming error" + +queryCalls :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyIncomingCall]) +queryCalls state t@CallHierarchyItem{..} = do + ShakeExtras{hiedb} <- getShakeExtras + let -- ShakeExtras{hiedb} = shakeExtras state + -- (Success (symbolStr :: String)) = fromJSON (fromJust _xdata) + -- symbol = read symbolStr :: Symbol + symbol = read (T.unpack $ fromJust _detail) + vs <- liftIO $ Q.incomingCalls hiedb symbol + r <- mapM (\ v + -> prepareCallHierarchyItem + state (toNormalizedFilePath' (hieSrc v)) (Position (sl v - 1) (sc v - 1))) vs + let nfp = fromJust $ uriToNormalizedFilePath $ toNormalizedUri _uri + pos = _range ^. L.start + f <- foiIncomingCalls nfp pos + let g = map (\x -> CallHierarchyIncomingCall x (List [])) (concat $ catMaybes r) + f <- if (not . null) f then liftIO $ error $ "non-empty " <> show f else pure f -- debug only + return $ pure g <> f + +queryCalls' :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyIncomingCall]) +queryCalls' state item + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + ShakeExtras{hiedb} <- getShakeExtras + maySymbol <- getSymbol nfp + case maySymbol of + Nothing -> error "CallHierarchy.Impossible" + Just symbol -> do + vs <- liftIO $ Q.incomingCalls hiedb symbol + nonFOIItems <- mapM (\ v -> prepareCallHierarchyItem + state (toNormalizedFilePath' (hieSrc v)) (Position (sl v - 1) (sc v - 1))) vs + foiRes <- foiIncomingCalls nfp pos + let nonFOIRes = map (\x -> CallHierarchyIncomingCall x (List [])) (concat $ catMaybes nonFOIItems) + pure $ pure nonFOIRes <> foiRes + | otherwise = pure Nothing + where + uri = item ^. L.uri + xdata = item ^. L.xdata + pos = item ^. (L.selectionRange . L.start) + + getSymbol nfp = + case item ^. L.xdata of + Just xdata -> case fromJSON xdata of + Success (symbolStr :: String) -> + case readMaybe symbolStr of + Just symbol -> pure $ Just symbol + Nothing -> getSymbolFromAst nfp pos + A.Error _ -> getSymbolFromAst nfp pos + Nothing -> getSymbolFromAst nfp pos + +-- Incoming calls for FOIs, caller range is broken apparently. +foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall]) +foiIncomingCalls nfp pos = + use GetHieAst nfp >>= + \case + Nothing -> pure Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ pointCommand hf pos nodeChildren of + Nothing -> pure Nothing + Just children -> pure $ Just $ mkIncomingCalls children + where + mkIncomingCalls asts = let infos = concatMap extract asts + items = mapMaybe (construct nfp) infos + in map (\item -> CallHierarchyIncomingCall item (List [item ^. L.selectionRange])) items -- obvious error of range + +readHieDbSymbol' :: IdeState -> CallHierarchyItem -> Action (Maybe Symbol) +readHieDbSymbol' state item = + case item ^. L.xdata of + Nothing -> pure $ loadFromAST + Just xdata -> case fromJSON xdata of + A.Error s -> pure $ loadFromAST + Success (symbolStr :: String) -> pure $ fromMaybe loadFromAST (readMaybe symbolStr) + where + loadFromAST = case uriToNormalizedFilePath $ toNormalizedUri (item ^. L.uri) of + Just nfp -> undefined + Nothing -> error "CallHierarchy.Impossible" + loadSymbol = undefined + pos = item ^. (L.selectionRange . L.start) + +getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) +getSymbolFromAst nfp pos = + use GetHieAst nfp >>= + \case + Nothing -> pure Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ pointCommand hf pos extract of + Just infos -> case (\(ident, _, _) -> mkSymbol ident) <$> listToMaybe infos of + Nothing -> pure Nothing + Just res -> pure res + Nothing -> pure Nothing + +-- withHieAst :: NormalizedFilePath -> Position -> (HieAST a -> b) -> (b -> c) -> Action (Maybe c) +-- withHieAst nfp pos f trans = +-- use GetHieAst nfp >>= +-- \case +-- Nothing -> pure Nothing +-- Just (HAR _ hf _ _ _) -> do +-- case listToMaybe $ pointCommand hf pos f of +-- Nothing -> pure Nothing +-- Just res -> pure $ Just (trans res) +-- where +-- getAst :: forall aa.Action (Maybe (HieASTs aa)) +-- getAst = +-- use GetHieAst nfp >>= +-- \case +-- Nothing -> pure Nothing +-- Just (HAR _ hf _ _ _) -> pure $ Just hf diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs new file mode 100644 index 0000000000..43bd1150e2 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.CallHierarchy.Query where + +import Database.SQLite.Simple +import GHC +import HieDb (HieDb (getConn), Symbol (..), + toNsChar) +import qualified HieDb +import Ide.Plugin.CallHierarchy.Types +import Module +import Name + +getReachableFrom :: HieDb -> Vertex -> IO [Vertex] +getReachableFrom (getConn -> conn) v = undefined + +incomingCalls :: HieDb -> Symbol -> IO [Vertex] +incomingCalls (getConn -> conn) Symbol{..} = do + let n = toNsChar (occNameSpace symName) : occNameString symName + m = moduleNameString $ moduleName symModule + u = unitIdString $ moduleUnitId symModule + query conn "select distinct rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec \ + \refs.sl, refs.sc, refs.el, refs.ec \ + \from refs \ + \join defs on defs.occ = refs.occ \ + \join decls rd on rd.hieFile = defs.hieFile and rd.occ = defs.occ \ + \join mods rm on rm.mod = refs.mod and rm.unit = refs.unit and rm.hieFile = defs.hieFile \ + \join decls on decls.hieFile = refs.hieFile \ + \join mods on mods.hieFile = decls.hieFile \ + \where \ + \(decls.occ = ? and defs.occ != ? and mods.mod = ? and mods.unit = ?) \ + \and \ + \((refs.sl > decls.sl) OR (refs.sl = decls.sl AND refs.sc > decls.sc)) \ + \and \ + \((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))" (n, n, m, u) + +outgoingCalls :: HieDb -> Symbol -> IO [Vertex] +outgoingCalls = incomingCalls diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs new file mode 100644 index 0000000000..5164e09a2f --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Ide.Plugin.CallHierarchy.Types where + +import Data.Aeson +import Database.SQLite.Simple +import Database.SQLite.Simple.ToField +import GHC.Generics + +data Vertex = Vertex { + mod :: String +, occ :: String +, hieSrc :: FilePath +, sl :: Int +, sc :: Int +, el :: Int +, ec :: Int +, casl :: Int -- sl for call appear +, casc :: Int -- sc for call appear +, cael :: Int -- el for call appear +, caec :: Int -- ec for call appear +} deriving (Eq, Show, Generic, FromJSON, ToJSON) + +instance ToRow Vertex where + toRow (Vertex a b c d e f g h i j k) = + [ toField a, toField b, toField c, toField d + , toField e, toField f, toField g, toField h + , toField i, toField j, toField k + ] + +instance FromRow Vertex where + fromRow = Vertex <$> field <*> field <*> field + <*> field <*> field <*> field + <*> field <*> field <*> field + <*> field <*> field From 2b84f2dd11fe9642d455bbea20b284b9dd8ac9a3 Mon Sep 17 00:00:00 2001 From: July541 Date: Wed, 7 Jul 2021 14:20:42 +0800 Subject: [PATCH 07/28] Rename incoming to outgoing --- .../src/Ide/Plugin/CallHierarchy.hs | 5 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 96 +++++++------------ .../src/Ide/Plugin/CallHierarchy/Query.hs | 8 +- 3 files changed, 42 insertions(+), 67 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 5747fcb6da..5d504df7c8 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -1,9 +1,12 @@ module Ide.Plugin.CallHierarchy where +import Development.IDE import qualified Ide.Plugin.CallHierarchy.Internal as X +import Ide.Types +import Language.LSP.Types descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy - <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls + <> mkPluginHandler SCallHierarchyOutgoingCalls X.outgoingCalls } diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 3fe64aa367..22c6e673d1 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -29,7 +29,7 @@ import Text.Read (readMaybe) prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state pluginId param | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = - liftIO (runAction "" state (prepareCallHierarchyItem state nfp pos)) >>= + liftIO (runAction "" state (prepareCallHierarchyItem nfp pos)) >>= \case Just items -> pure $ Right $ Just $ List items Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" @@ -38,18 +38,11 @@ prepareCallHierarchy state pluginId param uri = param ^. (L.textDocument . L.uri) pos = param ^. L.position -prepareCallHierarchyItem :: IdeState -> NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) -prepareCallHierarchyItem state nfp pos = do - fs <- getFilesOfInterestUntracked - if nfp `elem` HM.keys fs - then constructFromAst state nfp pos - else constructFromAst state nfp pos +prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +prepareCallHierarchyItem = constructFromAst -constructFromHieDb :: IdeState -> NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) -constructFromHieDb state nfp pos = undefined - -constructFromAst :: IdeState -> NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) -constructFromAst state nfp pos = +constructFromAst ::NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +constructFromAst nfp pos = use GetHieAst nfp >>= \case Nothing -> pure Nothing @@ -141,45 +134,28 @@ mkSymbol = \case Left _ -> Nothing Right name -> Just $ Symbol (occName name) (nameModule name) -incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls -incomingCalls state pluginId param = do - liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls state (param ^. L.item) >>= +incomingCalls = undefined + +outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls +outgoingCalls state pluginId param = do + liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls state (param ^. L.item) >>= \case Just x -> pure $ Right $ Just $ List x - Nothing -> pure $ Left $ responseError "incoming error" - -queryCalls :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyIncomingCall]) -queryCalls state t@CallHierarchyItem{..} = do - ShakeExtras{hiedb} <- getShakeExtras - let -- ShakeExtras{hiedb} = shakeExtras state - -- (Success (symbolStr :: String)) = fromJSON (fromJust _xdata) - -- symbol = read symbolStr :: Symbol - symbol = read (T.unpack $ fromJust _detail) - vs <- liftIO $ Q.incomingCalls hiedb symbol - r <- mapM (\ v - -> prepareCallHierarchyItem - state (toNormalizedFilePath' (hieSrc v)) (Position (sl v - 1) (sc v - 1))) vs - let nfp = fromJust $ uriToNormalizedFilePath $ toNormalizedUri _uri - pos = _range ^. L.start - f <- foiIncomingCalls nfp pos - let g = map (\x -> CallHierarchyIncomingCall x (List [])) (concat $ catMaybes r) - f <- if (not . null) f then liftIO $ error $ "non-empty " <> show f else pure f -- debug only - return $ pure g <> f - -queryCalls' :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyIncomingCall]) -queryCalls' state item + Nothing -> pure $ Left $ responseError "CallHierarchy.outgoingCalls error" + +queryCalls :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyOutgoingCall]) +queryCalls state item | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do ShakeExtras{hiedb} <- getShakeExtras maySymbol <- getSymbol nfp case maySymbol of Nothing -> error "CallHierarchy.Impossible" Just symbol -> do - vs <- liftIO $ Q.incomingCalls hiedb symbol - nonFOIItems <- mapM (\ v -> prepareCallHierarchyItem - state (toNormalizedFilePath' (hieSrc v)) (Position (sl v - 1) (sc v - 1))) vs - foiRes <- foiIncomingCalls nfp pos - let nonFOIRes = map (\x -> CallHierarchyIncomingCall x (List [])) (concat $ catMaybes nonFOIItems) - pure $ pure nonFOIRes <> foiRes + vs <- liftIO $ Q.outgoingCalls hiedb symbol + nonFOIItems <- mapM mkCallHierarchyOutgoingCall vs + foiRes <- foiOutgoingCalls nfp pos + let nonFOIRes = Just $ catMaybes nonFOIItems + pure (nonFOIRes <> foiRes) | otherwise = pure Nothing where uri = item ^. L.uri @@ -196,34 +172,30 @@ queryCalls' state item A.Error _ -> getSymbolFromAst nfp pos Nothing -> getSymbolFromAst nfp pos + mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) + mkCallHierarchyOutgoingCall Vertex{..} = do + let pos = Position (sl - 1) (sc - 1) + nfp = toNormalizedFilePath' hieSrc + range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) + items <- prepareCallHierarchyItem nfp pos + case items of + Just [item] -> pure $ Just $ CallHierarchyOutgoingCall item (List [range]) + _ -> pure Nothing + -- Incoming calls for FOIs, caller range is broken apparently. -foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall]) -foiIncomingCalls nfp pos = +foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall]) +foiOutgoingCalls nfp pos = use GetHieAst nfp >>= \case Nothing -> pure Nothing Just (HAR _ hf _ _ _) -> do case listToMaybe $ pointCommand hf pos nodeChildren of Nothing -> pure Nothing - Just children -> pure $ Just $ mkIncomingCalls children + Just children -> pure $ Just $ mkOutgoingCalls children where - mkIncomingCalls asts = let infos = concatMap extract asts + mkOutgoingCalls asts = let infos = concatMap extract asts items = mapMaybe (construct nfp) infos - in map (\item -> CallHierarchyIncomingCall item (List [item ^. L.selectionRange])) items -- obvious error of range - -readHieDbSymbol' :: IdeState -> CallHierarchyItem -> Action (Maybe Symbol) -readHieDbSymbol' state item = - case item ^. L.xdata of - Nothing -> pure $ loadFromAST - Just xdata -> case fromJSON xdata of - A.Error s -> pure $ loadFromAST - Success (symbolStr :: String) -> pure $ fromMaybe loadFromAST (readMaybe symbolStr) - where - loadFromAST = case uriToNormalizedFilePath $ toNormalizedUri (item ^. L.uri) of - Just nfp -> undefined - Nothing -> error "CallHierarchy.Impossible" - loadSymbol = undefined - pos = item ^. (L.selectionRange . L.start) + in map (\item -> CallHierarchyOutgoingCall item (List [item ^. L.selectionRange])) items -- obvious error of range getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) getSymbolFromAst nfp pos = diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index 43bd1150e2..e9e7ebab3c 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -16,8 +16,8 @@ import Name getReachableFrom :: HieDb -> Vertex -> IO [Vertex] getReachableFrom (getConn -> conn) v = undefined -incomingCalls :: HieDb -> Symbol -> IO [Vertex] -incomingCalls (getConn -> conn) Symbol{..} = do +outgoingCalls :: HieDb -> Symbol -> IO [Vertex] +outgoingCalls (getConn -> conn) Symbol{..} = do let n = toNsChar (occNameSpace symName) : occNameString symName m = moduleNameString $ moduleName symModule u = unitIdString $ moduleUnitId symModule @@ -36,5 +36,5 @@ incomingCalls (getConn -> conn) Symbol{..} = do \and \ \((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))" (n, n, m, u) -outgoingCalls :: HieDb -> Symbol -> IO [Vertex] -outgoingCalls = incomingCalls +incomingCalls :: HieDb -> Symbol -> IO [Vertex] +incomingCalls = undefined From 7a4139789be7c50d065c751d6e4451dfa0dcae22 Mon Sep 17 00:00:00 2001 From: July541 Date: Sun, 11 Jul 2021 21:28:04 +0800 Subject: [PATCH 08/28] Add incoming calls support --- .../hls-call-hierarchy-plugin.cabal | 1 + .../src/Ide/Plugin/CallHierarchy.hs | 1 + .../src/Ide/Plugin/CallHierarchy/Internal.hs | 92 ++++++++++++++----- .../src/Ide/Plugin/CallHierarchy/Query.hs | 35 +++++-- 4 files changed, 101 insertions(+), 28 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index b5e07a054a..960616b756 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -33,6 +33,7 @@ library , unordered-containers , sqlite-simple , bytestring + , extra default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 5d504df7c8..60f4380d29 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -8,5 +8,6 @@ import Language.LSP.Types descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy + <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls <> mkPluginHandler SCallHierarchyOutgoingCalls X.outgoingCalls } diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 22c6e673d1..f1c236605e 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,6 +7,7 @@ module Ide.Plugin.CallHierarchy.Internal where import Control.Lens (Field1 (_1), Field3 (_3), (^.)) +import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson as A import qualified Data.HashMap.Strict as HM @@ -29,7 +31,7 @@ import Text.Read (readMaybe) prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state pluginId param | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = - liftIO (runAction "" state (prepareCallHierarchyItem nfp pos)) >>= + liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem nfp pos)) >>= \case Just items -> pure $ Right $ Just $ List items Nothing -> pure $ Left $ responseError "Call Hierarchy: No result" @@ -123,37 +125,73 @@ mkCallHierarchyItem nfp ident kind span selSpan = (T.pack $ identifierName ident) kind Nothing - (T.pack . show <$> mkSymbol ident) + (Just $ T.pack $ identifierToDetail ident) (fromNormalizedUri $ normalizedFilePathToUri nfp) (realSrcSpanToRange span) (realSrcSpanToRange selSpan) (toJSON . show <$> mkSymbol ident) + where + identifierToDetail :: Identifier -> String + identifierToDetail = \case + Left modName -> moduleNameString modName + Right name -> (moduleNameString . moduleName . nameModule) name mkSymbol :: Identifier -> Maybe Symbol mkSymbol = \case Left _ -> Nothing Right name -> Just $ Symbol (occName name) (nameModule name) -incomingCalls = undefined +-- todo: remove duplication +incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls +incomingCalls state pluginId param = do + liftIO $ runAction "CallHierarchy.incomingCalls" state $ + queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall foiIncomingCalls >>= + \case + Just x -> pure $ Right $ Just $ List x + Nothing -> pure $ Left $ responseError "CallHierarchy.incomingCalls error" + where + mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) + mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls outgoingCalls state pluginId param = do - liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls state (param ^. L.item) >>= + liftIO $ runAction "CallHierarchy.outgoingCalls" state $ + queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall foiOutgoingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy.outgoingCalls error" + where + mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) + mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall + +-- todo: mutil range support +mkCallHierarchyCall builder Vertex{..} = do + let pos = Position (sl - 1) (sc - 1) + nfp = toNormalizedFilePath' hieSrc + range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) + items <- prepareCallHierarchyItem nfp pos + case items of + Just [item] -> pure $ Just $ builder item (List [range]) + _ -> pure Nothing -queryCalls :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyOutgoingCall]) -queryCalls state item +-- queryCalls :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyOutgoingCall]) +queryCalls :: (L.HasSelectionRange s a1, L.HasStart a1 Position, + L.HasXdata s (Maybe Value), L.HasXdata s a2, L.HasUri s Uri) => + s + -> (HieDb -> Symbol -> IO [a3]) + -> (a3 -> Action (Maybe a4)) + -> (NormalizedFilePath -> Position -> Action (Maybe [a4])) + -> Action (Maybe [a4]) +queryCalls item queryFunc makeFunc foiCalls | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do ShakeExtras{hiedb} <- getShakeExtras maySymbol <- getSymbol nfp case maySymbol of Nothing -> error "CallHierarchy.Impossible" Just symbol -> do - vs <- liftIO $ Q.outgoingCalls hiedb symbol - nonFOIItems <- mapM mkCallHierarchyOutgoingCall vs - foiRes <- foiOutgoingCalls nfp pos + vs <- liftIO $ queryFunc hiedb symbol + nonFOIItems <- mapM makeFunc vs + foiRes <- foiCalls nfp pos let nonFOIRes = Just $ catMaybes nonFOIItems pure (nonFOIRes <> foiRes) | otherwise = pure Nothing @@ -165,24 +203,36 @@ queryCalls state item getSymbol nfp = case item ^. L.xdata of Just xdata -> case fromJSON xdata of - Success (symbolStr :: String) -> + A.Success (symbolStr :: String) -> case readMaybe symbolStr of Just symbol -> pure $ Just symbol Nothing -> getSymbolFromAst nfp pos A.Error _ -> getSymbolFromAst nfp pos Nothing -> getSymbolFromAst nfp pos - mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) - mkCallHierarchyOutgoingCall Vertex{..} = do - let pos = Position (sl - 1) (sc - 1) - nfp = toNormalizedFilePath' hieSrc - range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) - items <- prepareCallHierarchyItem nfp pos - case items of - Just [item] -> pure $ Just $ CallHierarchyOutgoingCall item (List [range]) - _ -> pure Nothing - --- Incoming calls for FOIs, caller range is broken apparently. +foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall]) +foiIncomingCalls nfp pos = + use GetHieAst nfp >>= + \case + Nothing -> pure Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ pointCommand hf pos id of + Nothing -> pure Nothing + Just ast -> do + fs <- HM.keys <$> getFilesOfInterestUntracked + Just . concatMap (`callers` ast) <$> mapMaybeM (use GetHieAst) fs + where + callers :: HieAstResult -> HieAST a -> [CallHierarchyIncomingCall] + callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf) + + sameAst :: HieAST a -> HieAST b -> Bool + sameAst ast1 ast2 = (M.keys .nodeIdentifiers . nodeInfo) ast1 == (M.keys .nodeIdentifiers . nodeInfo) ast2 + + mkIncomingCalls asts = let infos = concatMap extract asts + items = mapMaybe (construct nfp) infos + in map (\item -> CallHierarchyIncomingCall item (List [item ^. L.selectionRange])) items + +-- Outgoing calls for FOIs, caller range is broken apparently. foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall]) foiOutgoingCalls nfp pos = use GetHieAst nfp >>= diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index e9e7ebab3c..7f160f5f18 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -13,15 +13,30 @@ import Ide.Plugin.CallHierarchy.Types import Module import Name -getReachableFrom :: HieDb -> Vertex -> IO [Vertex] -getReachableFrom (getConn -> conn) v = undefined +incomingCalls :: HieDb -> Symbol -> IO [Vertex] +incomingCalls (getConn -> conn) symbol = do + let (o, m, u) = parseSymbol symbol + query conn "select distinct mods.mod, defs.occ, mods.hs_src, defs.sl, defs.sc, \ + \defs.el, defs.ec, refs.sl, refs.sc, refs.el, refs.ec \ + \from refs \ + \join decls on decls.hieFile = refs.hieFile \ + \join defs on defs.hieFile = decls.hieFile and defs.occ = decls.occ \ + \join mods on mods.hieFile = decls.hieFile \ + \where \ + \(refs.occ = ? and refs.mod = ? and refs.unit = ?) \ + \and \ + \(decls.occ != ? or mods.mod != ? or mods.unit != ?) \ + \and \ + \((refs.sl = decls.sl and refs.sc > decls.sc) or (refs.sl > decls.sl)) \ + \and \ + \((refs.el = decls.el and refs.ec <= decls.ec) or (refs.el < decls.el))" (o, m, u, o, m, u) outgoingCalls :: HieDb -> Symbol -> IO [Vertex] outgoingCalls (getConn -> conn) Symbol{..} = do let n = toNsChar (occNameSpace symName) : occNameString symName m = moduleNameString $ moduleName symModule u = unitIdString $ moduleUnitId symModule - query conn "select distinct rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec \ + query conn "select distinct rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, \ \refs.sl, refs.sc, refs.el, refs.ec \ \from refs \ \join defs on defs.occ = refs.occ \ @@ -30,11 +45,17 @@ outgoingCalls (getConn -> conn) Symbol{..} = do \join decls on decls.hieFile = refs.hieFile \ \join mods on mods.hieFile = decls.hieFile \ \where \ - \(decls.occ = ? and defs.occ != ? and mods.mod = ? and mods.unit = ?) \ + \(decls.occ = ? and mods.mod = ? and mods.unit = ?) \ + \and \ + \(defs.occ != ? or rm.mod != ? or rm.unit != ?) \ \and \ \((refs.sl > decls.sl) OR (refs.sl = decls.sl AND refs.sc > decls.sc)) \ \and \ - \((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))" (n, n, m, u) + \((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))" (n, m, u, n, m, u) -incomingCalls :: HieDb -> Symbol -> IO [Vertex] -incomingCalls = undefined +parseSymbol :: Symbol -> (String, String, String) +parseSymbol Symbol{..} = + let o = toNsChar (occNameSpace symName) : occNameString symName + m = moduleNameString $ moduleName symModule + u = unitIdString $ moduleUnitId symModule + in (o, m, u) From 0018dd06a73d1ecf71992299af2dd98792d4342d Mon Sep 17 00:00:00 2001 From: July541 Date: Mon, 12 Jul 2021 15:27:23 +0800 Subject: [PATCH 09/28] Fix panic error caused by parameters --- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index f1c236605e..a44fea177a 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -83,6 +83,8 @@ patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs] construct :: NormalizedFilePath -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem construct nfp (ident, contexts, ssp) + | isInternalIdentifier ident = Nothing + | Just (RecField RecFieldDecl _) <- recFieldInfo contexts -- ignored type span = Just $ mkCallHierarchyItem' ident SkField ssp ssp @@ -109,7 +111,7 @@ construct nfp (ident, contexts, ssp) | Just (PatternBind _ _ span) <- patternBindInfo contexts = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - | Just Use <- useInfo contexts + | Just Use <- useInfo contexts -- todo: Use may be a type signature.. = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp | otherwise = Nothing @@ -119,6 +121,10 @@ construct nfp (ident, contexts, ssp) skUnknown = SkUnknown 27 mkCallHierarchyItem' = mkCallHierarchyItem nfp + isInternalIdentifier = \case + Left _ -> False + Right name -> isInternalName name + mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem mkCallHierarchyItem nfp ident kind span selSpan = CallHierarchyItem From 04679f1d25761e09b89e5d89d9d86df480ae8f08 Mon Sep 17 00:00:00 2001 From: July541 Date: Tue, 13 Jul 2021 21:54:02 +0800 Subject: [PATCH 10/28] Prepare callhierarchy tests --- .../hls-call-hierarchy-plugin.cabal | 1 + .../hls-call-hierarchy-plugin/test/Main.hs | 45 ++++++++++++------- 2 files changed, 30 insertions(+), 16 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 960616b756..5c68106e32 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -46,6 +46,7 @@ test-suite tests main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: + , aeson , base , hls-call-hierarchy-plugin , hls-test-utils diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 9f97adaee3..0a7e8ca966 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -3,6 +3,7 @@ module Main where import Control.Lens +import Data.Aeson import qualified Data.Text as T import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test @@ -24,68 +25,68 @@ prepareCallHierarchyTests = let contents = T.unlines ["a=3"] range = mkRange 0 0 0 3 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItem "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SkFunction range selRange oneCaseWithCreate contents 0 0 expected , testCase "function" $ do let contents = T.unlines ["a=(+)"] range = mkRange 0 0 0 5 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItem "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SkFunction range selRange oneCaseWithCreate contents 0 0 expected , testCase "datatype" $ do let contents = T.unlines ["data A=A"] range = mkRange 0 0 0 8 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItem "A" SkStruct range selRange + expected = mkCallHierarchyItemT "A" SkStruct range selRange oneCaseWithCreate contents 0 5 expected , testCase "data constructor" $ do let contents = T.unlines ["data A=A"] range = mkRange 0 7 0 8 selRange = mkRange 0 7 0 8 - expected = mkCallHierarchyItem "A" SkConstructor range selRange + expected = mkCallHierarchyItemC "A" SkConstructor range selRange oneCaseWithCreate contents 0 7 expected , testCase "record" $ do let contents = T.unlines ["data A=A{a::Int}"] range = mkRange 0 9 0 10 selRange = mkRange 0 9 0 10 - expected = mkCallHierarchyItem "a" SkField range selRange + expected = mkCallHierarchyItemV "a" SkField range selRange oneCaseWithCreate contents 0 9 expected , testCase "type operator" $ do let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] range = mkRange 1 0 1 15 selRange = mkRange 1 5 1 9 - expected = mkCallHierarchyItem "><" SkTypeParameter range selRange + expected = mkCallHierarchyItemT "><" SkTypeParameter range selRange oneCaseWithCreate contents 1 5 expected , testCase "type class" $ do let contents = T.unlines ["class A a where a :: a -> Int"] range = mkRange 0 0 0 29 selRange = mkRange 0 6 0 7 - expected = mkCallHierarchyItem "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SkInterface range selRange oneCaseWithCreate contents 0 6 expected , testCase "type class method" $ do let contents = T.unlines ["class A a where a :: a -> Int"] range = mkRange 0 16 0 29 selRange = mkRange 0 16 0 17 - expected = mkCallHierarchyItem "a" SkMethod range selRange + expected = mkCallHierarchyItemV "a" SkMethod range selRange oneCaseWithCreate contents 0 16 expected , testCase "type class instance" $ do -- TODO: add details to prevent ambiguous let contents = T.unlines ["class A a where", "instance A () where"] range = mkRange 1 9 1 10 selRange = mkRange 1 9 1 10 - expected = mkCallHierarchyItem "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SkInterface range selRange oneCaseWithCreate contents 1 9 expected , testGroup "type family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"] range = mkRange 1 0 1 13 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItem "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SkFunction range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"] range = mkRange 1 0 1 15 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItem "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SkFunction range selRange oneCaseWithCreate contents 1 12 expected ] , testCase "type family instance" $ do @@ -96,7 +97,7 @@ prepareCallHierarchyTests = ] range = mkRange 2 14 2 23 selRange = mkRange 2 14 2 15 - expected = mkCallHierarchyItem "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SkInterface range selRange oneCaseWithCreate contents 2 14 expected -- , testGroup "data family" -- [ testCase "1" $ do @@ -126,19 +127,19 @@ prepareCallHierarchyTests = let contents = T.unlines ["Just x = Just 3"] range = mkRange 0 0 0 15 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItem "x" SkFunction range selRange + expected = mkCallHierarchyItemV "x" SkFunction range selRange oneCaseWithCreate contents 0 5 expected , testCase "pattern with type signature" $ do let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"] range = mkRange 1 0 1 12 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItem "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SkFunction range selRange oneCaseWithCreate contents 1 0 expected , testCase "type synonym" $ do let contents = T.unlines ["type A=Bool"] range = mkRange 0 0 0 11 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItem "A" SkTypeParameter range selRange + expected = mkCallHierarchyItemT "A" SkTypeParameter range selRange oneCaseWithCreate contents 0 5 expected , testCase "GADT" $ do let contents = T.unlines @@ -147,7 +148,7 @@ prepareCallHierarchyTests = ] range = mkRange 1 13 1 26 selRange = mkRange 1 13 1 14 - expected = mkCallHierarchyItem "A" SkConstructor range selRange + expected = mkCallHierarchyItemC "A" SkConstructor range selRange oneCaseWithCreate contents 1 13 expected ] @@ -173,6 +174,18 @@ mkCallHierarchyItem :: T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHier mkCallHierarchyItem name kind range selRange uri = CallHierarchyItem name kind Nothing Nothing uri range selRange Nothing +mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem +mkCallHierarchyItem' prefix name kind range selRange uri = + CallHierarchyItem name kind Nothing (Just "Main") uri range selRange (Just v) + where + v = toJSON $ prefix <> ":" <> T.unpack name <> ":Main:main" + +mkCallHierarchyItemC, mkCallHierarchyItemT, mkCallHierarchyItemV :: + T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem +mkCallHierarchyItemC = mkCallHierarchyItem' "c" +mkCallHierarchyItemT = mkCallHierarchyItem' "t" +mkCallHierarchyItemV = mkCallHierarchyItem' "v" + testDataDir :: FilePath testDataDir = "test" "testdata" From 59e2432d8456f6430374779702fe36dd69f73311 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 15 Jul 2021 15:30:24 +0800 Subject: [PATCH 11/28] Duplication items support --- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 107 +++++++++--------- 1 file changed, 51 insertions(+), 56 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index a44fea177a..c7f90d82c2 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} module Ide.Plugin.CallHierarchy.Internal where import Control.Lens (Field1 (_1), Field3 (_3), (^.)) @@ -11,6 +12,7 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson as A import qualified Data.HashMap.Strict as HM +import Data.List (groupBy, sortBy) import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S @@ -43,7 +45,7 @@ prepareCallHierarchy state pluginId param prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) prepareCallHierarchyItem = constructFromAst -constructFromAst ::NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +constructFromAst :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) constructFromAst nfp pos = use GetHieAst nfp >>= \case @@ -63,22 +65,13 @@ identifierName = \case Left modName -> moduleNameString modName Right name -> occNameString $ nameOccName name -recFieldInfo :: S.Set ContextInfo -> Maybe ContextInfo -recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] - -declInfo :: S.Set ContextInfo -> Maybe ContextInfo -declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] - -valBindInfo :: S.Set ContextInfo -> Maybe ContextInfo -valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] - -classTyDeclInfo :: S.Set ContextInfo -> Maybe ContextInfo +recFieldInfo, declInfo, valBindInfo, classTyDeclInfo, + useInfo, patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo +recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] +declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] +valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- S.toList ctxs] - -useInfo :: S.Set ContextInfo -> Maybe ContextInfo -useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] - -patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo +useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs] construct :: NormalizedFilePath -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem @@ -92,17 +85,16 @@ construct nfp (ident, contexts, ssp) | Just ctx <- valBindInfo contexts = Just $ case ctx of ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - _ -> mkCallHierarchyItem' ident skUnknown ssp ssp + _ -> mkCallHierarchyItem' ident skUnknown ssp ssp | Just ctx <- declInfo contexts = Just $ case ctx of - -- TODO: sort in alphabetical order - Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp - Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp + Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp | Just (ClassTyDecl span) <- classTyDeclInfo contexts @@ -111,7 +103,7 @@ construct nfp (ident, contexts, ssp) | Just (PatternBind _ _ span) <- patternBindInfo contexts = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - | Just Use <- useInfo contexts -- todo: Use may be a type signature.. + | Just Use <- useInfo contexts = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp | otherwise = Nothing @@ -147,11 +139,15 @@ mkSymbol = \case Left _ -> Nothing Right name -> Just $ Symbol (occName name) (nameModule name) --- todo: remove duplication +deriving instance Ord SymbolKind +deriving instance Ord SymbolTag +deriving instance Ord CallHierarchyItem + incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls incomingCalls state pluginId param = do liftIO $ runAction "CallHierarchy.incomingCalls" state $ - queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall foiIncomingCalls >>= + queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall + foiIncomingCalls mergeIncomingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy.incomingCalls error" @@ -159,10 +155,19 @@ incomingCalls state pluginId param = do mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall + mergeIncomingCalls :: [CallHierarchyIncomingCall] -> [CallHierarchyIncomingCall] + mergeIncomingCalls = map merge + . groupBy (\a b -> a ^. L.from == b ^. L.from) + . sortBy (\a b -> (a ^. L.from) `compare` (b ^. L.from)) + where + merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls + in CallHierarchyIncomingCall (head calls ^. L.from) (List ranges) + outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls outgoingCalls state pluginId param = do liftIO $ runAction "CallHierarchy.outgoingCalls" state $ - queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall foiOutgoingCalls >>= + queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall + foiOutgoingCalls mergeOutgoingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy.outgoingCalls error" @@ -170,7 +175,15 @@ outgoingCalls state pluginId param = do mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall --- todo: mutil range support + mergeOutgoingCalls :: [CallHierarchyOutgoingCall] -> [CallHierarchyOutgoingCall] + mergeOutgoingCalls = map merge + . groupBy (\a b -> a ^. L.to == b ^. L.to) + . sortBy (\a b -> (a ^. L.to) `compare` (b ^. L.to)) + where + merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls + in CallHierarchyOutgoingCall (head calls ^. L.to) (List ranges) + +mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) mkCallHierarchyCall builder Vertex{..} = do let pos = Position (sl - 1) (sc - 1) nfp = toNormalizedFilePath' hieSrc @@ -180,15 +193,14 @@ mkCallHierarchyCall builder Vertex{..} = do Just [item] -> pure $ Just $ builder item (List [range]) _ -> pure Nothing --- queryCalls :: IdeState -> CallHierarchyItem -> Action (Maybe [CallHierarchyOutgoingCall]) -queryCalls :: (L.HasSelectionRange s a1, L.HasStart a1 Position, - L.HasXdata s (Maybe Value), L.HasXdata s a2, L.HasUri s Uri) => - s - -> (HieDb -> Symbol -> IO [a3]) - -> (a3 -> Action (Maybe a4)) - -> (NormalizedFilePath -> Position -> Action (Maybe [a4])) - -> Action (Maybe [a4]) -queryCalls item queryFunc makeFunc foiCalls +queryCalls :: (Show a) + => CallHierarchyItem + -> (HieDb -> Symbol -> IO [Vertex]) + -> (Vertex -> Action (Maybe a)) + -> (NormalizedFilePath -> Position -> Action (Maybe [a])) + -> ([a] -> [a]) + -> Action (Maybe [a]) +queryCalls item queryFunc makeFunc foiCalls merge | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do ShakeExtras{hiedb} <- getShakeExtras maySymbol <- getSymbol nfp @@ -199,7 +211,7 @@ queryCalls item queryFunc makeFunc foiCalls nonFOIItems <- mapM makeFunc vs foiRes <- foiCalls nfp pos let nonFOIRes = Just $ catMaybes nonFOIItems - pure (nonFOIRes <> foiRes) + pure $ merge <$> (nonFOIRes <> foiRes) | otherwise = pure Nothing where uri = item ^. L.uri @@ -236,7 +248,7 @@ foiIncomingCalls nfp pos = mkIncomingCalls asts = let infos = concatMap extract asts items = mapMaybe (construct nfp) infos - in map (\item -> CallHierarchyIncomingCall item (List [item ^. L.selectionRange])) items + in map (\item -> CallHierarchyIncomingCall item (List [item ^. L.selectionRange])) items -- todo: use span to instead -- Outgoing calls for FOIs, caller range is broken apparently. foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall]) @@ -264,20 +276,3 @@ getSymbolFromAst nfp pos = Nothing -> pure Nothing Just res -> pure res Nothing -> pure Nothing - --- withHieAst :: NormalizedFilePath -> Position -> (HieAST a -> b) -> (b -> c) -> Action (Maybe c) --- withHieAst nfp pos f trans = --- use GetHieAst nfp >>= --- \case --- Nothing -> pure Nothing --- Just (HAR _ hf _ _ _) -> do --- case listToMaybe $ pointCommand hf pos f of --- Nothing -> pure Nothing --- Just res -> pure $ Just (trans res) --- where --- getAst :: forall aa.Action (Maybe (HieASTs aa)) --- getAst = --- use GetHieAst nfp >>= --- \case --- Nothing -> pure Nothing --- Just (HAR _ hf _ _ _) -> pure $ Just hf From ad133b74b50422d7ede2d73994660a2318834a5e Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 15 Jul 2021 16:32:41 +0800 Subject: [PATCH 12/28] Format and add missing components for review --- ghcide/test/exe/Main.hs | 1 + plugins/hls-call-hierarchy-plugin/LICENSE | 201 ++++++++++++++++++ .../hls-call-hierarchy-plugin.cabal | 32 ++- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 77 ++++--- .../src/Ide/Plugin/CallHierarchy/Query.hs | 56 +++-- .../src/Ide/Plugin/CallHierarchy/Types.hs | 5 +- .../hls-call-hierarchy-plugin/test/Main.hs | 72 ++++++- stack-8.10.2.yaml | 1 + stack-8.10.3.yaml | 1 + stack-8.10.4.yaml | 1 + stack-8.10.5.yaml | 1 + stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack-8.8.3.yaml | 1 + stack-8.8.4.yaml | 1 + stack-9.0.1.yaml | 1 + stack.yaml | 1 + 17 files changed, 367 insertions(+), 87 deletions(-) create mode 100644 plugins/hls-call-hierarchy-plugin/LICENSE diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9f67fcdcb7..182777e7e9 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -194,6 +194,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk " call hierarchy" _callHierarchyProvider (Just $ InL True) , chk "NO experimental" _experimental Nothing ] where diff --git a/plugins/hls-call-hierarchy-plugin/LICENSE b/plugins/hls-call-hierarchy-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 5c68106e32..f3286b7542 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -3,7 +3,7 @@ name: hls-call-hierarchy-plugin version: 1.0.0.0 synopsis: Call hierarchy plugin for Haskell Language Server license: Apache-2.0 --- license-file: LICENSE +license-file: LICENSE author: Lei Zhu maintainer: julytreee@gmail.com category: Development @@ -13,27 +13,24 @@ extra-source-files: test/testdata/*.hs library exposed-modules: Ide.Plugin.CallHierarchy other-modules: + Ide.Plugin.CallHierarchy.Internal Ide.Plugin.CallHierarchy.Query Ide.Plugin.CallHierarchy.Types - Ide.Plugin.CallHierarchy.Internal hs-source-dirs: src build-depends: - , base >=4.12 && <5 - , ghcide >=1.2 && <1.5 - , hls-plugin-api ^>=1.1 - , lsp + , aeson + , base >=4.12 && <5 , containers - , hiedb + , extra , ghc + , ghcide >=1.2 && <1.5 + , hiedb + , hls-plugin-api ^>=1.1 , lens + , lsp + , sqlite-simple , text - , aeson - , mtl - , transformers , unordered-containers - , sqlite-simple - , bytestring - , extra default-language: Haskell2010 default-extensions: @@ -48,10 +45,11 @@ test-suite tests build-depends: , aeson , base - , hls-call-hierarchy-plugin - , hls-test-utils + , extra , filepath - , lsp-test - , lsp + , hls-call-hierarchy-plugin + , hls-test-utils ^>=1.0 , lens + , lsp + , lsp-test , text diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index c7f90d82c2..fa3193ca14 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -5,9 +5,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -module Ide.Plugin.CallHierarchy.Internal where +module Ide.Plugin.CallHierarchy.Internal ( + prepareCallHierarchy +, incomingCalls +, outgoingCalls +) where -import Control.Lens (Field1 (_1), Field3 (_3), (^.)) +import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson as A @@ -60,18 +64,13 @@ extract ast = let span = nodeSpan ast infos = M.toList $ M.map identInfo (nodeIdentifiers $ nodeInfo ast) in [ (ident, contexts, span) | (ident, contexts) <- infos ] -identifierName :: Identifier -> String -identifierName = \case - Left modName -> moduleNameString modName - Right name -> occNameString $ nameOccName name - recFieldInfo, declInfo, valBindInfo, classTyDeclInfo, useInfo, patternBindInfo :: S.Set ContextInfo -> Maybe ContextInfo -recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] -declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] -valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] +recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- S.toList ctxs] +declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- S.toList ctxs] +valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- S.toList ctxs] classTyDeclInfo ctxs = listToMaybe [ctx | ctx@ClassTyDecl{} <- S.toList ctxs] -useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] +useInfo ctxs = listToMaybe [Use | Use <- S.toList ctxs] patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- S.toList ctxs] construct :: NormalizedFilePath -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem @@ -110,7 +109,9 @@ construct nfp (ident, contexts, ssp) where renderSpan = \case Just span -> span _ -> ssp + skUnknown = SkUnknown 27 + mkCallHierarchyItem' = mkCallHierarchyItem nfp isInternalIdentifier = \case @@ -134,11 +135,19 @@ mkCallHierarchyItem nfp ident kind span selSpan = Left modName -> moduleNameString modName Right name -> (moduleNameString . moduleName . nameModule) name + identifierName :: Identifier -> String + identifierName = \case + Left modName -> moduleNameString modName + Right name -> occNameString $ nameOccName name + mkSymbol :: Identifier -> Maybe Symbol mkSymbol = \case Left _ -> Nothing Right name -> Just $ Symbol (occName name) (nameModule name) + +-- Incoming calls and outgoing calls + deriving instance Ord SymbolKind deriving instance Ord SymbolTag deriving instance Ord CallHierarchyItem @@ -150,7 +159,7 @@ incomingCalls state pluginId param = do foiIncomingCalls mergeIncomingCalls >>= \case Just x -> pure $ Right $ Just $ List x - Nothing -> pure $ Left $ responseError "CallHierarchy.incomingCalls error" + Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error" where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall @@ -170,7 +179,7 @@ outgoingCalls state pluginId param = do foiOutgoingCalls mergeOutgoingCalls >>= \case Just x -> pure $ Right $ Just $ List x - Nothing -> pure $ Left $ responseError "CallHierarchy.outgoingCalls error" + Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error" where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall @@ -184,15 +193,16 @@ outgoingCalls state pluginId param = do in CallHierarchyOutgoingCall (head calls ^. L.to) (List ranges) mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) -mkCallHierarchyCall builder Vertex{..} = do +mkCallHierarchyCall mk Vertex{..} = do let pos = Position (sl - 1) (sc - 1) nfp = toNormalizedFilePath' hieSrc range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) items <- prepareCallHierarchyItem nfp pos case items of - Just [item] -> pure $ Just $ builder item (List [range]) + Just [item] -> pure $ Just $ mk item (List [range]) _ -> pure Nothing +-- Unified queries include incoming calls and outgoing calls. queryCalls :: (Show a) => CallHierarchyItem -> (HieDb -> Symbol -> IO [Vertex]) @@ -210,6 +220,7 @@ queryCalls item queryFunc makeFunc foiCalls merge vs <- liftIO $ queryFunc hiedb symbol nonFOIItems <- mapM makeFunc vs foiRes <- foiCalls nfp pos + if isJust foiRes && (length <$> foiRes) /= Just 0 then liftIO $ putStrLn (show "fois:" <> show foiRes) else pure () let nonFOIRes = Just $ catMaybes nonFOIItems pure $ merge <$> (nonFOIRes <> foiRes) | otherwise = pure Nothing @@ -228,6 +239,18 @@ queryCalls item queryFunc makeFunc foiCalls merge A.Error _ -> getSymbolFromAst nfp pos Nothing -> getSymbolFromAst nfp pos + getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) + getSymbolFromAst nfp pos = + use GetHieAst nfp >>= + \case + Nothing -> pure Nothing + Just (HAR _ hf _ _ _) -> do + case listToMaybe $ pointCommand hf pos extract of + Just infos -> case (\(ident, _, _) -> mkSymbol ident) <$> listToMaybe infos of + Nothing -> pure Nothing + Just res -> pure res + Nothing -> pure Nothing + foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall]) foiIncomingCalls nfp pos = use GetHieAst nfp >>= @@ -244,13 +267,15 @@ foiIncomingCalls nfp pos = callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf) sameAst :: HieAST a -> HieAST b -> Bool - sameAst ast1 ast2 = (M.keys .nodeIdentifiers . nodeInfo) ast1 == (M.keys .nodeIdentifiers . nodeInfo) ast2 + sameAst ast1 ast2 = (M.keys .nodeIdentifiers . nodeInfo) ast1 + == (M.keys .nodeIdentifiers . nodeInfo) ast2 mkIncomingCalls asts = let infos = concatMap extract asts items = mapMaybe (construct nfp) infos - in map (\item -> CallHierarchyIncomingCall item (List [item ^. L.selectionRange])) items -- todo: use span to instead + in map (\item -> + CallHierarchyIncomingCall item + (List [item ^. L.selectionRange])) items --- Outgoing calls for FOIs, caller range is broken apparently. foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall]) foiOutgoingCalls nfp pos = use GetHieAst nfp >>= @@ -263,16 +288,6 @@ foiOutgoingCalls nfp pos = where mkOutgoingCalls asts = let infos = concatMap extract asts items = mapMaybe (construct nfp) infos - in map (\item -> CallHierarchyOutgoingCall item (List [item ^. L.selectionRange])) items -- obvious error of range - -getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) -getSymbolFromAst nfp pos = - use GetHieAst nfp >>= - \case - Nothing -> pure Nothing - Just (HAR _ hf _ _ _) -> do - case listToMaybe $ pointCommand hf pos extract of - Just infos -> case (\(ident, _, _) -> mkSymbol ident) <$> listToMaybe infos of - Nothing -> pure Nothing - Just res -> pure res - Nothing -> pure Nothing + in map (\item -> + CallHierarchyOutgoingCall item + (List [item ^. L.selectionRange]) ) items diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index 7f160f5f18..8f9701f730 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -16,42 +16,40 @@ import Name incomingCalls :: HieDb -> Symbol -> IO [Vertex] incomingCalls (getConn -> conn) symbol = do let (o, m, u) = parseSymbol symbol - query conn "select distinct mods.mod, defs.occ, mods.hs_src, defs.sl, defs.sc, \ + query conn "SELECT mods.mod, defs.occ, mods.hs_src, defs.sl, defs.sc, \ \defs.el, defs.ec, refs.sl, refs.sc, refs.el, refs.ec \ - \from refs \ - \join decls on decls.hieFile = refs.hieFile \ - \join defs on defs.hieFile = decls.hieFile and defs.occ = decls.occ \ - \join mods on mods.hieFile = decls.hieFile \ + \FROM refs \ + \JOIN decls ON decls.hieFile = refs.hieFile \ + \JOIN defs ON defs.hieFile = decls.hieFile AND defs.occ = decls.occ \ + \JOIN mods ON mods.hieFile = decls.hieFile \ \where \ - \(refs.occ = ? and refs.mod = ? and refs.unit = ?) \ - \and \ - \(decls.occ != ? or mods.mod != ? or mods.unit != ?) \ - \and \ - \((refs.sl = decls.sl and refs.sc > decls.sc) or (refs.sl > decls.sl)) \ - \and \ - \((refs.el = decls.el and refs.ec <= decls.ec) or (refs.el < decls.el))" (o, m, u, o, m, u) + \(refs.occ = ? AND refs.mod = ? AND refs.unit = ?) \ + \AND \ + \(decls.occ != ? OR mods.mod != ? OR mods.unit != ?) \ + \AND \ + \((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) \ + \AND \ + \((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" (o, m, u, o, m, u) outgoingCalls :: HieDb -> Symbol -> IO [Vertex] -outgoingCalls (getConn -> conn) Symbol{..} = do - let n = toNsChar (occNameSpace symName) : occNameString symName - m = moduleNameString $ moduleName symModule - u = unitIdString $ moduleUnitId symModule - query conn "select distinct rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, \ +outgoingCalls (getConn -> conn) symbol = do + let (o, m, u) = parseSymbol symbol + query conn "SELECT rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, \ \refs.sl, refs.sc, refs.el, refs.ec \ \from refs \ - \join defs on defs.occ = refs.occ \ - \join decls rd on rd.hieFile = defs.hieFile and rd.occ = defs.occ \ - \join mods rm on rm.mod = refs.mod and rm.unit = refs.unit and rm.hieFile = defs.hieFile \ - \join decls on decls.hieFile = refs.hieFile \ - \join mods on mods.hieFile = decls.hieFile \ + \JOIN defs ON defs.occ = refs.occ \ + \JOIN decls rd ON rd.hieFile = defs.hieFile AND rd.occ = defs.occ \ + \JOIN mods rm ON rm.mod = refs.mod AND rm.unit = refs.unit AND rm.hieFile = defs.hieFile \ + \JOIN decls ON decls.hieFile = refs.hieFile \ + \JOIN mods ON mods.hieFile = decls.hieFile \ \where \ - \(decls.occ = ? and mods.mod = ? and mods.unit = ?) \ - \and \ - \(defs.occ != ? or rm.mod != ? or rm.unit != ?) \ - \and \ - \((refs.sl > decls.sl) OR (refs.sl = decls.sl AND refs.sc > decls.sc)) \ - \and \ - \((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))" (n, m, u, n, m, u) + \(decls.occ = ? AND mods.mod = ? AND mods.unit = ?) \ + \AND \ + \(defs.occ != ? OR rm.mod != ? OR rm.unit != ?) \ + \AND \ + \((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) \ + \AND \ + \((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" (o, m, u, o, m, u) parseSymbol :: Symbol -> (String, String, String) parseSymbol Symbol{..} = diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs index 5164e09a2f..be9934c464 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} module Ide.Plugin.CallHierarchy.Types where diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 0a7e8ca966..22fad7b6ab 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} module Main where -import Control.Lens +import Control.Lens (set, (^.)) +import Control.Monad.Extra import Data.Aeson +import Data.List (sort) import qualified Data.Text as T import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test @@ -11,6 +15,8 @@ import qualified Language.LSP.Types.Lens as L import System.FilePath import Test.Hls +import Data.Functor ((<&>)) + plugin :: PluginDescriptor IdeState plugin = descriptor "callHierarchy" @@ -152,14 +158,63 @@ prepareCallHierarchyTests = oneCaseWithCreate contents 1 13 expected ] -oneCaseWithOpen :: FilePath -> Int -> Int -> CallHierarchyItem -> Assertion -oneCaseWithOpen filename queryX queryY expected = +incomingCallsTests :: TestTree +incomingCallsTests = + testGroup "Incoming Calls" + [ testGroup "single file" + [ + testCase "xdata unavaliable" $ + runSessionWithServer plugin testDataDir $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] + [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) + let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= + \case + [item] -> do + let itemNoData = set L.xdata Nothing item + Test.incomingCalls (mkIncomingCallsParam itemNoData) >>= + \res -> liftIO $ sort expected @=? sort res + _ -> liftIO $ assertFailure "Not exactly one element" + closeDoc doc + , testCase "xdata avaliable" $ do + let contents = T.unlines ["a=3", "b=a"] + positions = [(1, 0)] + ranges = [mkRange 1 2 1 3] + foiTestCase contents 0 0 positions ranges + , testGroup "data" + [ testCase "data type" $ do + let contents = T.unlines ["data A=A"] + positions = [] + ranges = [] + foiTestCase contents 0 5 positions ranges + , testCase "data constructor" $ do + let contents = T.unlines ["data A=A{a::Int}"] + positions = [(0, 7)] + ranges = [mkRange 0 5 0 6] + foiTestCase contents 0 5 positions ranges + ] + ] + ] + +deriving instance Ord CallHierarchyIncomingCall +deriving instance Ord CallHierarchyOutgoingCall + +foiTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion +foiTestCase contents queryX queryY positions ranges = runSessionWithServer plugin testDataDir $ do - doc <- openDoc filename "haskell" + doc <- createDoc "A.hs" "haskell" contents + items <- concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) + <&> map (,range) + ) + (zip positions ranges) + let expected = map mkCallHierarchyIncomingCall items Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case - [item] -> liftIO $ item @?= expected + [item] -> Test.incomingCalls (mkIncomingCallsParam item) >>= + \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not one element" + closeDoc doc oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion oneCaseWithCreate contents queryX queryY expected = @@ -186,6 +241,9 @@ mkCallHierarchyItemC = mkCallHierarchyItem' "c" mkCallHierarchyItemT = mkCallHierarchyItem' "t" mkCallHierarchyItemV = mkCallHierarchyItem' "v" +mkCallHierarchyIncomingCall :: (CallHierarchyItem, Range) -> CallHierarchyIncomingCall +mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item (List [range]) + testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index cbe1077c61..133f457f15 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -8,6 +8,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index f3da34fb04..fe8a98a186 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -8,6 +8,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 571ac51df7..78181f2cdb 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -8,6 +8,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index 2fc6323085..ba0b1d3552 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -10,6 +10,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 75e1f30245..e491d3954d 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -9,6 +9,7 @@ packages: # - ./shake-bench - ./hls-plugin-api - ./hls-test-utils + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 30cb1b1d13..cdc1d05c31 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -8,6 +8,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index dc530f81dc..6ef578558b 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -8,6 +8,7 @@ packages: - ./shake-bench - ./hls-plugin-api - ./hls-test-utils + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 821483e7e0..1cdab18f40 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -8,6 +8,7 @@ packages: - ./shake-bench - ./hls-plugin-api - ./hls-test-utils + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index df5aca2c33..9efcabef76 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -9,6 +9,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin # - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack.yaml b/stack.yaml index 124b5f7943..7323a3c8ed 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,6 +8,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench + - ./plugins/hls-call-hierarchy-plugin - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin From db5bb4dcebc93c6ae5f09e609095a3076765bd67 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 15 Jul 2021 17:19:16 +0800 Subject: [PATCH 13/28] Use local lsp --- stack-8.10.2.yaml | 11 ++++++++--- stack-8.10.3.yaml | 11 ++++++++--- stack-8.10.4.yaml | 11 ++++++++--- stack-8.10.5.yaml | 11 ++++++++--- stack-8.6.4.yaml | 11 ++++++++--- stack-8.6.5.yaml | 11 ++++++++--- stack-8.8.3.yaml | 11 ++++++++--- stack-8.8.4.yaml | 11 ++++++++--- stack-9.0.1.yaml | 2 +- stack.yaml | 11 ++++++++--- 10 files changed, 73 insertions(+), 28 deletions(-) diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 133f457f15..6313f2bb61 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -44,9 +44,6 @@ extra-deps: - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - heapsize-0.3.0 - hie-bios-0.7.5 - implicit-hie-cradle-0.3.0.2 @@ -68,6 +65,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + configure-options: ghcide: - --disable-library-for-ghci diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index fe8a98a186..ce7b4ecbac 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -58,9 +58,6 @@ extra-deps: - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.4.0.0 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -68,6 +65,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + configure-options: ghcide: - --disable-library-for-ghci diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 78181f2cdb..6c74640e43 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -54,9 +54,6 @@ extra-deps: - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.4.0.0 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -64,6 +61,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + # Enable these when supported by all formatters # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 # - ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index ba0b1d3552..d73d3bc2a6 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -56,9 +56,6 @@ extra-deps: - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.4.0.0 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -66,6 +63,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + # Enable these when supported by all formatters # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 # - ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index e491d3954d..6be559d553 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -95,9 +95,6 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.4.0.0 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -106,6 +103,14 @@ extra-deps: - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + flags: haskell-language-server: pedantic: true diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index cdc1d05c31..e23438b576 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -96,9 +96,6 @@ extra-deps: - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.4.0.0 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -107,6 +104,14 @@ extra-deps: - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + configure-options: ghcide: - --disable-library-for-ghci diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 6ef578558b..f490b1805e 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -75,9 +75,6 @@ extra-deps: - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -85,6 +82,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + configure-options: ghcide: - --disable-library-for-ghci diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 1cdab18f40..5feaa3026d 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -72,9 +72,6 @@ extra-deps: - hiedb-0.4.0.0 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -82,6 +79,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + configure-options: ghcide: - --disable-library-for-ghci diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 9efcabef76..cf2714138b 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -9,7 +9,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench - - ./plugins/hls-call-hierarchy-plugin + # - ./plugins/hls-call-hierarchy-plugin # - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin diff --git a/stack.yaml b/stack.yaml index 7323a3c8ed..d11a03264d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -51,9 +51,6 @@ extra-deps: - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.4.0.0 - - lsp-1.2.0.0 - - lsp-types-1.2.0.0 - - lsp-test-0.14.0.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 @@ -61,6 +58,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: July541/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-tests + # https://github.com/haskell/lsp/pull/332 + configure-options: ghcide: - --disable-library-for-ghci From ec420ad50d5396959ca87e00e735c2f451698e81 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 15 Jul 2021 17:20:50 +0800 Subject: [PATCH 14/28] Add CI test --- .github/workflows/test.yml | 4 ++++ .../hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal | 4 +++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 34526ab0d5..3c46b08364 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -197,3 +197,7 @@ jobs: - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" + + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} + name: Test hls-call-hierarchy-plugin test suite + run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index f3286b7542..ea53120fed 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -8,7 +8,9 @@ author: Lei Zhu maintainer: julytreee@gmail.com category: Development build-type: Simple -extra-source-files: test/testdata/*.hs +extra-source-files: + LICENSE + test/testdata/*.hs library exposed-modules: Ide.Plugin.CallHierarchy From eec1c986f7363437f149b53f077b3403c128246a Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 15 Jul 2021 17:33:55 +0800 Subject: [PATCH 15/28] Fix typo --- stack-8.10.2.yaml | 2 +- stack-8.10.3.yaml | 2 +- stack-8.10.4.yaml | 2 +- stack-8.10.5.yaml | 2 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.3.yaml | 2 +- stack-8.8.4.yaml | 2 +- stack.yaml | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 6313f2bb61..9abe3e09f3 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -70,7 +70,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 configure-options: diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index ce7b4ecbac..ea60f736d1 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -70,7 +70,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 configure-options: diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 6c74640e43..8bd8e19f26 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -66,7 +66,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 # Enable these when supported by all formatters diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index d73d3bc2a6..cb31ca68cb 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -68,7 +68,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 # Enable these when supported by all formatters diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 6be559d553..3f201ba7a4 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -108,7 +108,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 flags: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index e23438b576..9ac2ffc453 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -109,7 +109,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 configure-options: diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index f490b1805e..04101ec2b1 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -87,7 +87,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 configure-options: diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 5feaa3026d..994fac3f2d 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -84,7 +84,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 configure-options: diff --git a/stack.yaml b/stack.yaml index d11a03264d..bb33fa547a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -63,7 +63,7 @@ extra-deps: subdirs: - lsp-types - lsp - - lsp-tests + - lsp-test # https://github.com/haskell/lsp/pull/332 configure-options: From 047174f607095201e157eb8cf582818906efc5d0 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 15 Jul 2021 19:50:45 +0800 Subject: [PATCH 16/28] Add flag for 9.0.1 --- stack-9.0.1.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index cf2714138b..8357c157a3 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -111,6 +111,7 @@ configure-options: flags: haskell-language-server: pedantic: true + callHierarchy: false class: false splice: false refineImports: false From 25927ef780804845793f94157780220d52908df9 Mon Sep 17 00:00:00 2001 From: July541 Date: Fri, 16 Jul 2021 20:56:35 +0800 Subject: [PATCH 17/28] Change lsp repo --- stack-8.10.2.yaml | 2 +- stack-8.10.3.yaml | 2 +- stack-8.10.4.yaml | 2 +- stack-8.10.5.yaml | 2 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.3.yaml | 2 +- stack-8.8.4.yaml | 2 +- stack.yaml | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 9abe3e09f3..e4de622715 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -65,7 +65,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index ea60f736d1..82af0ae3d7 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -65,7 +65,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 8bd8e19f26..8c9089ad73 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -61,7 +61,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index cb31ca68cb..0d59f76c94 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -63,7 +63,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 3f201ba7a4..8ac07216f8 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -103,7 +103,7 @@ extra-deps: - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 9ac2ffc453..2299458996 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -104,7 +104,7 @@ extra-deps: - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 04101ec2b1..bbda5e51a2 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -82,7 +82,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 994fac3f2d..a2b737a0ed 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -79,7 +79,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types diff --git a/stack.yaml b/stack.yaml index bb33fa547a..719361c64d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -58,7 +58,7 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - - github: July541/lsp + - github: haskell/lsp commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdirs: - lsp-types From a529246cabd2b763c7591d158a018403536d46bb Mon Sep 17 00:00:00 2001 From: July541 Date: Wed, 21 Jul 2021 22:59:34 +0800 Subject: [PATCH 18/28] Fix query error in data declaration --- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 37 +++++++++++++------ .../src/Ide/Plugin/CallHierarchy/Query.hs | 10 +++++ .../src/Ide/Plugin/CallHierarchy/Types.hs | 15 +++++++- 3 files changed, 49 insertions(+), 13 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index fa3193ca14..3c2ae2fb59 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -21,17 +21,21 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T +import Data.Tuple.Extra import Development.IDE import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Spans.AtPoint +import Development.IDE.Spans.Common import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types import Ide.Types import Language.LSP.Types import qualified Language.LSP.Types.Lens as L +import Maybes import Name +import SrcLoc import Text.Read (readMaybe) prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy @@ -146,7 +150,9 @@ mkSymbol = \case Right name -> Just $ Symbol (occName name) (nameModule name) --- Incoming calls and outgoing calls +---------------------------------------------------------------------- +-------------- Incoming calls and outgoing calls --------------------- +---------------------------------------------------------------------- deriving instance Ord SymbolKind deriving instance Ord SymbolTag @@ -193,16 +199,26 @@ outgoingCalls state pluginId param = do in CallHierarchyOutgoingCall (head calls ^. L.to) (List ranges) mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) -mkCallHierarchyCall mk Vertex{..} = do +mkCallHierarchyCall mk v@Vertex{..} = do let pos = Position (sl - 1) (sc - 1) nfp = toNormalizedFilePath' hieSrc range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) - items <- prepareCallHierarchyItem nfp pos - case items of - Just [item] -> pure $ Just $ mk item (List [range]) - _ -> pure Nothing --- Unified queries include incoming calls and outgoing calls. + prepareCallHierarchyItem nfp pos >>= + \case + Just [item] -> pure $ Just $ mk item (List [range]) + _ -> do + ShakeExtras{hiedb} <- getShakeExtras + liftIO (Q.getSymbolPosition hiedb v) >>= + \case + (x:_) -> + prepareCallHierarchyItem nfp (Position (psl x - 1) (psc x - 1)) >>= + \case + Just [item] -> pure $ Just $ mk item (List [range]) + _ -> pure Nothing + _ -> pure Nothing + +-- | Unified queries include incoming calls and outgoing calls. queryCalls :: (Show a) => CallHierarchyItem -> (HieDb -> Symbol -> IO [Vertex]) @@ -220,7 +236,6 @@ queryCalls item queryFunc makeFunc foiCalls merge vs <- liftIO $ queryFunc hiedb symbol nonFOIItems <- mapM makeFunc vs foiRes <- foiCalls nfp pos - if isJust foiRes && (length <$> foiRes) /= Just 0 then liftIO $ putStrLn (show "fois:" <> show foiRes) else pure () let nonFOIRes = Just $ catMaybes nonFOIItems pure $ merge <$> (nonFOIRes <> foiRes) | otherwise = pure Nothing @@ -246,7 +261,7 @@ queryCalls item queryFunc makeFunc foiCalls merge Nothing -> pure Nothing Just (HAR _ hf _ _ _) -> do case listToMaybe $ pointCommand hf pos extract of - Just infos -> case (\(ident, _, _) -> mkSymbol ident) <$> listToMaybe infos of + Just infos -> case mkSymbol . fst3 <$> listToMaybe infos of Nothing -> pure Nothing Just res -> pure res Nothing -> pure Nothing @@ -267,8 +282,8 @@ foiIncomingCalls nfp pos = callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf) sameAst :: HieAST a -> HieAST b -> Bool - sameAst ast1 ast2 = (M.keys .nodeIdentifiers . nodeInfo) ast1 - == (M.keys .nodeIdentifiers . nodeInfo) ast2 + sameAst ast1 ast2 = (M.keys . nodeIdentifiers . nodeInfo) ast1 + == (M.keys . nodeIdentifiers . nodeInfo) ast2 mkIncomingCalls asts = let infos = concatMap extract asts items = mapMaybe (construct nfp) infos diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index 8f9701f730..aa6fe34597 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -51,6 +51,16 @@ outgoingCalls (getConn -> conn) symbol = do \AND \ \((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" (o, m, u, o, m, u) +getSymbolPosition :: HieDb -> Vertex -> IO [SymbolPosition] +getSymbolPosition (getConn -> conn) Vertex{..} = do + query conn "SELECT refs.sl, refs.sc from refs where \ + \(occ = ?) \ + \AND \ + \((refs.sl = ? AND refs.sc > ?) OR (refs.sl > ?)) \ + \AND \ + \((refs.el = ? AND refs.ec <= ?) OR (refs.el < ?))" + (occ, sl, sc, sl, el, ec, el) + parseSymbol :: Symbol -> (String, String, String) parseSymbol Symbol{..} = let o = toNsChar (occNameSpace symName) : occNameString symName diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs index be9934c464..0c10d95ca0 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} module Ide.Plugin.CallHierarchy.Types where @@ -34,3 +35,13 @@ instance FromRow Vertex where <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field +data SymbolPosition = SymbolPosition { + psl :: Int +, psc :: Int +} deriving (Eq, Show, Generic, FromJSON, ToJSON) + +instance ToRow SymbolPosition where + toRow (SymbolPosition a b) = toRow (a, b) + +instance FromRow SymbolPosition where + fromRow = SymbolPosition <$> field <*> field From dcf8aab3cdafbbb6fc1dcfa70ae284cfc01333d2 Mon Sep 17 00:00:00 2001 From: July541 Date: Wed, 21 Jul 2021 23:01:07 +0800 Subject: [PATCH 19/28] Add incoming/outgoing call tests --- .../hls-call-hierarchy-plugin.cabal | 1 + .../hls-call-hierarchy-plugin/test/Main.hs | 355 +++++++++++++++--- .../test/testdata/A.hs | 15 +- .../test/testdata/B.hs | 17 +- .../test/testdata/C.hs | 2 +- 5 files changed, 318 insertions(+), 72 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index ea53120fed..b65e44a4db 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -47,6 +47,7 @@ test-suite tests build-depends: , aeson , base + , containers , extra , filepath , hls-call-hierarchy-plugin diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 22fad7b6ab..bd8b5718a5 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -13,15 +13,24 @@ import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test import qualified Language.LSP.Types.Lens as L import System.FilePath +import qualified System.IO.Extra import Test.Hls +import Control.Concurrent.Extra import Data.Functor ((<&>)) +import qualified Data.Map as M +import System.Directory.Extra plugin :: PluginDescriptor IdeState plugin = descriptor "callHierarchy" main :: IO () -main = defaultTestRunner $ testGroup "Call Hierarchy" [prepareCallHierarchyTests] +main = defaultTestRunner $ + testGroup "Call Hierarchy" + [ prepareCallHierarchyTests + , incomingCallsTests + , outgoingCallsTests + ] prepareCallHierarchyTests :: TestTree prepareCallHierarchyTests = @@ -75,7 +84,7 @@ prepareCallHierarchyTests = selRange = mkRange 0 16 0 17 expected = mkCallHierarchyItemV "a" SkMethod range selRange oneCaseWithCreate contents 0 16 expected - , testCase "type class instance" $ do -- TODO: add details to prevent ambiguous + , testCase "type class instance" $ do let contents = T.unlines ["class A a where", "instance A () where"] range = mkRange 1 9 1 10 selRange = mkRange 1 9 1 10 @@ -105,30 +114,30 @@ prepareCallHierarchyTests = selRange = mkRange 2 14 2 15 expected = mkCallHierarchyItemT "A" SkInterface range selRange oneCaseWithCreate contents 2 14 expected - -- , testGroup "data family" - -- [ testCase "1" $ do - -- let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] - -- range = mkRange 1 0 1 13 - -- selRange = mkRange 1 12 1 13 - -- expected = mkCallHierarchyItem "A" SkFunction range selRange - -- oneCaseWithCreate contents 1 12 expected - -- , testCase "2" $ do - -- let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] - -- range = mkRange 1 0 1 15 - -- selRange = mkRange 1 12 1 13 - -- expected = mkCallHierarchyItem "A" SkFunction range selRange - -- oneCaseWithCreate contents 1 12 expected - -- ] - -- , testCase "data family instance" $ do - -- let contents = T.unlines - -- [ "{-# LANGUAGE TypeFamilies #-}" - -- , "data family A a" - -- , "data instance A () = A()" - -- ] - -- range = mkRange 2 0 2 24 - -- selRange = mkRange 2 14 2 15 - -- expected = mkCallHierarchyItem "A" SkInterface range selRange - -- oneCaseWithCreate contents 2 14 expected + , testGroup "data family" + [ testCase "1" $ do + let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] + range = mkRange 1 0 1 11 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItemT "A" SkFunction range selRange + oneCaseWithCreate contents 1 12 expected + , testCase "2" $ do + let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] + range = mkRange 1 0 1 11 + selRange = mkRange 1 12 1 13 + expected = mkCallHierarchyItemT "A" SkFunction range selRange + oneCaseWithCreate contents 1 12 expected + ] + , testCase "data family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "data family A a" + , "data instance A () = A()" + ] + range = mkRange 2 14 2 24 + selRange = mkRange 2 14 2 15 + expected = mkCallHierarchyItemT "A" SkInterface range selRange + oneCaseWithCreate contents 2 14 expected , testCase "pattern" $ do let contents = T.unlines ["Just x = Just 3"] range = mkRange 0 0 0 15 @@ -163,11 +172,12 @@ incomingCallsTests = testGroup "Incoming Calls" [ testGroup "single file" [ - testCase "xdata unavaliable" $ + testCase "xdata unavailable" $ runSessionWithServer plugin testDataDir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] + liftIO delay -- A hack, ensure HieDb be initilized. Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= \case [item] -> do @@ -176,58 +186,288 @@ incomingCallsTests = \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not exactly one element" closeDoc doc - , testCase "xdata avaliable" $ do - let contents = T.unlines ["a=3", "b=a"] + , testCase "xdata available" $ do + let contents = T.unlines ["a=3","b=a"] positions = [(1, 0)] ranges = [mkRange 1 2 1 3] - foiTestCase contents 0 0 positions ranges + incomingCallTestCase contents 0 1 positions ranges , testGroup "data" [ testCase "data type" $ do - let contents = T.unlines ["data A=A"] - positions = [] - ranges = [] - foiTestCase contents 0 5 positions ranges + let contents = T.unlines ["data A=A"] + positions = [] + ranges = [] + incomingCallTestCase contents 0 5 positions ranges , testCase "data constructor" $ do - let contents = T.unlines ["data A=A{a::Int}"] - positions = [(0, 7)] - ranges = [mkRange 0 5 0 6] - foiTestCase contents 0 5 positions ranges + let contents = T.unlines ["data A=A"] + positions = [(0, 5)] + ranges = [mkRange 0 7 0 8] + incomingCallTestCase contents 0 7 positions ranges + , testCase "record" $ do + let contents = T.unlines ["data A=A{a::Int}"] + positions = [(0, 5), (0, 7)] + ranges = [mkRange 0 9 0 10, mkRange 0 9 0 10] + incomingCallTestCase contents 0 9 positions ranges + ] + , testCase "function" $ do + let contents = T.unlines ["a=(+)"] + positions = [(0, 0)] + ranges = [mkRange 0 2 0 5] + incomingCallTestCase contents 0 3 positions ranges + , testCase "type operator" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeOperators #-}" + , "type (><)=Int"] + positions = [(1, 5)] + ranges = [mkRange 1 10 1 13] + incomingCallTestCase contents 1 10 positions ranges + , testGroup "type class" + [ testCase "type class method" $ do + let contents = T.unlines ["class A a where a :: a -> Int"] + positions = [(0, 6)] + ranges = [mkRange 0 16 0 17] + incomingCallTestCase contents 0 16 positions ranges + , testCase "type class instance" $ do + let contents = T.unlines + [ "class A a where a :: a -> Int" + , "instance A () where a = const 3"] + positions = [(0, 6)] + ranges = [mkRange 0 16 0 17] + incomingCallTestCase contents 1 20 positions ranges ] + , testCase "type family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "type family A a" + , "type instance A Int = Char" + ] + positions = [(1, 12)] + ranges = [mkRange 2 22 2 26] + incomingCallTestCase contents 2 22 positions ranges + , testCase "GADT" $ do + let contents = T.unlines + [ "{-# LANGUAGE GADTs #-}" + , "data A where B :: Int -> A" + ] + positions = [(1, 5)] + ranges = [mkRange 1 13 1 14] + incomingCallTestCase contents 1 13 positions ranges + ] + , testGroup "multi file" + [ testCase "1" $ do + let mp = M.fromList [ + ("A.hs", [ ((5, 0), mkRange 5 7 5 11) + , ((6, 0), mkRange 6 7 6 11) + , ((8, 0), mkRange 9 25 9 29) + ] + )] + incomingCallMultiFileTestCase "A.hs" 4 0 mp + , testCase "2" $ do + let mp = M.fromList [ + ("A.hs", [ ((4, 0), mkRange 4 13 4 16) + , ((8, 0), mkRange 10 7 10 10) + ] + ) + , ("B.hs", [ ((4, 0), mkRange 4 8 4 11)]) + ] + incomingCallMultiFileTestCase "C.hs" 2 0 mp + ] + ] + +outgoingCallsTests :: TestTree +outgoingCallsTests = + testGroup "Outgoing Calls" + [ testGroup "single file" + [ + testCase "xdata unavailable" $ withTempDir $ \dir -> + runSessionWithServer plugin dir $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] + [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) + let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] + liftIO delay + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= + \case + [item] -> do + let itemNoData = set L.xdata Nothing item + Test.outgoingCalls (mkOutgoingCallsParam itemNoData) >>= + \res -> liftIO $ sort expected @=? sort res + _ -> liftIO $ assertFailure "Not exactly one element" + closeDoc doc + , testCase "xdata available" $ do + let contents = T.unlines ["a=3", "b=a"] + positions = [(0, 0)] + ranges = [mkRange 1 2 1 3] + outgoingCallTestCase contents 1 0 positions ranges + , testGroup "data" + [ testCase "data type" $ do + let contents = T.unlines ["data A=A"] + positions = [(0, 7)] + ranges = [mkRange 0 7 0 8] + outgoingCallTestCase contents 0 5 positions ranges + , testCase "data constructor" $ do + let contents = T.unlines ["data A=A"] + positions = [] + ranges = [] + outgoingCallTestCase contents 0 7 positions ranges + , testCase "record" $ do + let contents = T.unlines ["data A=A{a::Int}"] + positions = [(0, 7), (0, 9)] + ranges = [mkRange 0 7 0 8, mkRange 0 9 0 10] + outgoingCallTestCase contents 0 5 positions ranges + ] + , testCase "function" $ do + let contents = T.unlines ["a=3", "b=4", "c=a+b"] + positions = [(0, 1), (1, 1)] + ranges = [mkRange 2 2 2 3, mkRange 2 4 2 5] + outgoingCallTestCase contents 2 0 positions ranges + , testCase "type synonym" $ do + let contents = T.unlines ["data A", "type B=A"] + positions = [(0, 5)] + ranges = [mkRange 1 7 1 8] + outgoingCallTestCase contents 1 5 positions ranges + , testCase "type class instance" $ do + let contents = T.unlines + [ "class A a where a :: a" + , "instance A () where a = ()" + ] + positions = [(0, 16)] + ranges = [mkRange 0 16 0 17] + outgoingCallTestCase contents 1 9 positions ranges + , testCase "data family instance" $ do + let contents = T.unlines + [ "{-# LANGUAGE TypeFamilies #-}" + , "data family A a" + , "data instance A () = B" + ] + positions = [(2, 21)] + ranges = [mkRange 2 21 2 22] + outgoingCallTestCase contents 1 12 positions ranges + , testCase "GADT" $ do + let contents = T.unlines ["{-# LANGUAGE GADTs #-}", "data A where B :: A"] + positions = [(1, 13)] + ranges = [mkRange 1 13 1 14] + outgoingCallTestCase contents 1 5 positions ranges + ] + , testGroup "multi file" + [ testCase "1" $ do + let mp = M.fromList [ + ("A.hs", [ ((4, 0), mkRange 5 7 5 11)]) + , ("B.hs", [ ((4, 0), mkRange 5 14 5 17)]) + , ("C.hs", [ ((3, 0), mkRange 5 20 5 23)]) + ] + outgoingCallMultiFileTestCase "A.hs" 5 0 mp + , testCase "2" $ do + let mp = M.fromList [ + ("A.hs", [ ((4, 0), mkRange 9 25 9 29) + , ((5, 0), mkRange 10 25 10 29) + ] + ) + , ("B.hs", [ ((2, 9), mkRange 9 2 9 3) + , ((2, 13), mkRange 10 2 10 3) + , ((4, 0), mkRange 9 7 9 10) + , ((5, 0), mkRange 9 13 9 16) + , ((6, 0), mkRange 9 19 9 22) + ] + ) + , ("C.hs", [ ((2, 0), mkRange 10 7 10 10) + , ((3, 0), mkRange 10 13 10 16) + , ((4, 0), mkRange 10 19 10 22) + ] + ) + ] + outgoingCallMultiFileTestCase "A.hs" 8 0 mp ] ] deriving instance Ord CallHierarchyIncomingCall deriving instance Ord CallHierarchyOutgoingCall -foiTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion -foiTestCase contents queryX queryY positions ranges = - runSessionWithServer plugin testDataDir $ do +incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion +incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir -> + runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents items <- concatMapM (\((x, y), range) -> - Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) - <&> map (,range) - ) - (zip positions ranges) + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) + <&> map (, range) + ) + (zip positions ranges) let expected = map mkCallHierarchyIncomingCall items + liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case - [item] -> Test.incomingCalls (mkIncomingCallsParam item) >>= + [item] -> do + Test.incomingCalls (mkIncomingCallsParam item) >>= \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not one element" closeDoc doc -oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion -oneCaseWithCreate contents queryX queryY expected = +incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion +incomingCallMultiFileTestCase filepath queryX queryY mp = runSessionWithServer plugin testDataDir $ do + doc <- openDoc filepath "haskell" + items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> + openDoc fp "haskell" >>= \p -> + concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y) + <&> map (, range) + ) pr) mp + let expected = map mkCallHierarchyIncomingCall items + liftIO delay + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= + \case + [item] -> do + Test.incomingCalls (mkIncomingCallsParam item) >>= + \res -> liftIO $ sort expected @=? sort res + _ -> liftIO $ assertFailure "Not one element" + closeDoc doc + +outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion +outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir -> + runSessionWithServer plugin dir $ do + doc <- createDoc "A.hs" "haskell" contents + items <- concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) + <&> map (, range) + ) + (zip positions ranges) + let expected = map mkCallHierarchyOutgoingCall items + liftIO delay + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= + \case + [item] -> do + Test.outgoingCalls (mkOutgoingCallsParam item) >>= + \res -> liftIO $ sort expected @=? sort res + _ -> liftIO $ assertFailure "Not one element" + closeDoc doc + +outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion +outgoingCallMultiFileTestCase filepath queryX queryY mp = + runSessionWithServer plugin testDataDir $ do + doc <- openDoc filepath "haskell" + items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> + openDoc fp "haskell" >>= \p -> + concatMapM (\((x, y), range) -> + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y) + <&> map (, range) + ) pr) mp + let expected = map mkCallHierarchyOutgoingCall items + liftIO delay + Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= + \case + [item] -> do + Test.outgoingCalls (mkOutgoingCallsParam item) >>= + \res -> liftIO $ sort expected @=? sort res + _ -> liftIO $ assertFailure "Not one element" + closeDoc doc + +oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion +oneCaseWithCreate contents queryX queryY expected = withTempDir $ \dir -> + runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> liftIO $ item @?= expected (doc ^. L.uri) res -> liftIO $ assertFailure "Not one element" - -mkCallHierarchyItem :: T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -mkCallHierarchyItem name kind range selRange uri = - CallHierarchyItem name kind Nothing Nothing uri range selRange Nothing + closeDoc doc mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem mkCallHierarchyItem' prefix name kind range selRange uri = @@ -244,6 +484,9 @@ mkCallHierarchyItemV = mkCallHierarchyItem' "v" mkCallHierarchyIncomingCall :: (CallHierarchyItem, Range) -> CallHierarchyIncomingCall mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item (List [range]) +mkCallHierarchyOutgoingCall :: (CallHierarchyItem, Range) -> CallHierarchyOutgoingCall +mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item (List [range]) + testDataDir :: FilePath testDataDir = "test" "testdata" @@ -255,3 +498,11 @@ mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing + +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +delay :: IO () +delay = threadDelay 1000000 diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs index 36af15f5a2..c31455d63b 100644 --- a/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs @@ -1,10 +1,11 @@ module A where -import B +import B import C + foo1 = B.a + C.a -foo2 = C.c + c -foo3 = foo1 + foo2 -foo4 :: Bool -foo4 = g -foo5 :: Integer -foo5 = g \ No newline at end of file +foo2 = foo1 + B.a + C.b +foo3 = foo1 + foo2 + C.c + +bar x = case x of + A -> B.a + B.b + B.c + foo1 + B -> C.a + C.b + C.c + foo2 diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs index 34c92bc8e6..44a7fc9504 100644 --- a/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs @@ -1,14 +1,7 @@ -module B (a, b, F(g)) where +module B where +import qualified C +data T = A | B -class F a where - g :: a - -instance F Integer where - g = 3 - -instance F Bool where - g = True - -a = 3 +a = 3 + C.a b = 4 -c = 5 \ No newline at end of file +c = 5 diff --git a/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs b/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs index 0c9a39b6d7..ab7d2158ae 100644 --- a/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/C.hs @@ -2,4 +2,4 @@ module C where a = 3 b = 4 -c = 5 \ No newline at end of file +c = 5 From 649a70ff1a962c46864950504becf82dc680133d Mon Sep 17 00:00:00 2001 From: July541 Date: Wed, 21 Jul 2021 23:31:18 +0800 Subject: [PATCH 20/28] Add flag for test ghc 9.0.1 --- haskell-language-server.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5c43658275..297a788176 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -437,6 +437,8 @@ test-suite func-test if flag(pedantic) ghc-options: -Werror -Wredundant-constraints + if flag(callHierarchy) || flag(all-plugins) + cpp-options: -DcallHierarchy if flag(class) || flag(all-plugins) cpp-options: -Dclass if flag(haddockComments) || flag(all-plugins) From 6ca06292b1f5f4af602c39a5da0c3c7532b79563 Mon Sep 17 00:00:00 2001 From: July541 Date: Wed, 21 Jul 2021 23:41:29 +0800 Subject: [PATCH 21/28] Ignore test on 9.0.1 --- cabal-ghc901.project | 2 +- stack-9.0.1.yaml | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 966fbf63ee..427dbf6228 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -87,7 +87,7 @@ index-state: 2021-07-14T20:31:09Z constraints: -- These plugins doesn't work on GHC9 yet - haskell-language-server -brittany -class -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports + haskell-language-server -callHierarchy -brittany -class -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports allow-newer: diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 560833230f..c1119557f1 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -112,7 +112,6 @@ configure-options: flags: haskell-language-server: pedantic: true - callHierarchy: false class: false splice: false refineImports: false From b6ead8ffc33592a65acd96dc324126b6d2dec784 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 22 Jul 2021 15:17:53 +0800 Subject: [PATCH 22/28] Add 9.0.1 test --- .github/workflows/test.yml | 2 +- cabal-ghc901.project | 3 ++- cabal.project | 18 ------------------ stack-9.0.1.yaml | 2 +- 4 files changed, 4 insertions(+), 21 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 0b671f7854..3d572eb28a 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -201,6 +201,6 @@ jobs: name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }} name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 427dbf6228..97e94a7437 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -22,6 +22,7 @@ packages: ./plugins/hls-pragmas-plugin ./plugins/hls-module-name-plugin -- ./plugins/hls-ormolu-plugin + ./plugins/hls-call-hierarchy-plugin tests: true package * @@ -87,7 +88,7 @@ index-state: 2021-07-14T20:31:09Z constraints: -- These plugins doesn't work on GHC9 yet - haskell-language-server -callHierarchy -brittany -class -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports + haskell-language-server -brittany -class -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports allow-newer: diff --git a/cabal.project b/cabal.project index 051cc10c2e..1fd0279148 100644 --- a/cabal.project +++ b/cabal.project @@ -84,21 +84,3 @@ allow-newer: svg-builder:base, these:base, time-compat:base - -source-repository-package - type: git - location: https://github.com/July541/lsp.git - tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 - subdir: lsp-types - -source-repository-package - type: git - location: https://github.com/July541/lsp.git - tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 - subdir: lsp-test - -source-repository-package - type: git - location: https://github.com/July541/lsp.git - tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 - subdir: lsp diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index c1119557f1..96de4dda17 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -9,7 +9,7 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench - # - ./plugins/hls-call-hierarchy-plugin + - ./plugins/hls-call-hierarchy-plugin # - ./plugins/hls-class-plugin - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin From fd11a10015a3236dce2bdeadc675ed9cadbe1fe4 Mon Sep 17 00:00:00 2001 From: July541 Date: Thu, 22 Jul 2021 15:26:18 +0800 Subject: [PATCH 23/28] Specifying lsp for cabal --- cabal.project | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/cabal.project b/cabal.project index 1fd0279148..e3464ab4dc 100644 --- a/cabal.project +++ b/cabal.project @@ -84,3 +84,21 @@ allow-newer: svg-builder:base, these:base, time-compat:base + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: e96383ab19534128f12acc70a69fbc15d4f298cc + subdir: lsp-types + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: e96383ab19534128f12acc70a69fbc15d4f298cc + subdir: lsp-test + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: e96383ab19534128f12acc70a69fbc15d4f298cc + subdir: lsp From c2bd2112f85ed007aa489d56724e5e4460d2277c Mon Sep 17 00:00:00 2001 From: July541 Date: Mon, 26 Jul 2021 17:08:26 +0800 Subject: [PATCH 24/28] Refresh hiedb before incoming/outgoing calls --- .github/workflows/test.yml | 2 +- cabal.project | 6 +- .../hls-call-hierarchy-plugin.cabal | 2 + .../src/Ide/Plugin/CallHierarchy.hs | 2 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 111 +++++++++--------- .../src/Ide/Plugin/CallHierarchy/Query.hs | 8 +- .../hls-call-hierarchy-plugin/test/Main.hs | 22 ++-- 7 files changed, 73 insertions(+), 80 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 3d572eb28a..3b43a0edd7 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -201,6 +201,6 @@ jobs: name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}} name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" diff --git a/cabal.project b/cabal.project index e3464ab4dc..9343f9cd6f 100644 --- a/cabal.project +++ b/cabal.project @@ -88,17 +88,17 @@ allow-newer: source-repository-package type: git location: https://github.com/haskell/lsp.git - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdir: lsp-types source-repository-package type: git location: https://github.com/haskell/lsp.git - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdir: lsp-test source-repository-package type: git location: https://github.com/haskell/lsp.git - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdir: lsp diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index b65e44a4db..2bfe7ac8f1 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -22,9 +22,11 @@ library build-depends: , aeson , base >=4.12 && <5 + , bytestring , containers , extra , ghc + , ghc-api-compat , ghcide >=1.2 && <1.5 , hiedb , hls-plugin-api ^>=1.1 diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 60f4380d29..ce21a79454 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -1,4 +1,4 @@ -module Ide.Plugin.CallHierarchy where +module Ide.Plugin.CallHierarchy (descriptor) where import Development.IDE import qualified Ide.Plugin.CallHierarchy.Internal as X diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 3c2ae2fb59..d9fa82eb2e 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -5,39 +5,42 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} + module Ide.Plugin.CallHierarchy.Internal ( prepareCallHierarchy , incomingCalls , outgoingCalls ) where +import Control.Concurrent import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson as A +import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import Data.List (groupBy, sortBy) import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Tuple.Extra import Development.IDE +import Development.IDE.Core.Compile import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Spans.AtPoint -import Development.IDE.Spans.Common import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types import Ide.Types import Language.LSP.Types import qualified Language.LSP.Types.Lens as L -import Maybes import Name -import SrcLoc import Text.Read (readMaybe) +-- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state pluginId param | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = @@ -92,11 +95,11 @@ construct nfp (ident, contexts, ssp) | Just ctx <- declInfo contexts = Just $ case ctx of - Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp - Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp - Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp + Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp @@ -125,7 +128,7 @@ construct nfp (ident, contexts, ssp) mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem mkCallHierarchyItem nfp ident kind span selSpan = CallHierarchyItem - (T.pack $ identifierName ident) + (T.pack $ optimize $ identifierName ident) kind Nothing (Just $ T.pack $ identifierToDetail ident) @@ -144,12 +147,16 @@ mkCallHierarchyItem nfp ident kind span selSpan = Left modName -> moduleNameString modName Right name -> occNameString $ nameOccName name + optimize :: String -> String + optimize name -- optimize display for DuplicateRecordFields + | "$sel:" == take 5 name = drop 5 name + | otherwise = name + mkSymbol :: Identifier -> Maybe Symbol mkSymbol = \case Left _ -> Nothing Right name -> Just $ Symbol (occName name) (nameModule name) - ---------------------------------------------------------------------- -------------- Incoming calls and outgoing calls --------------------- ---------------------------------------------------------------------- @@ -158,11 +165,12 @@ deriving instance Ord SymbolKind deriving instance Ord SymbolTag deriving instance Ord CallHierarchyItem +-- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls incomingCalls state pluginId param = do liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall - foiIncomingCalls mergeIncomingCalls >>= + mergeIncomingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error" @@ -178,11 +186,12 @@ incomingCalls state pluginId param = do merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls in CallHierarchyIncomingCall (head calls ^. L.from) (List ranges) +-- Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls outgoingCalls state pluginId param = do liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall - foiOutgoingCalls mergeOutgoingCalls >>= + mergeOutgoingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error" @@ -223,21 +232,20 @@ queryCalls :: (Show a) => CallHierarchyItem -> (HieDb -> Symbol -> IO [Vertex]) -> (Vertex -> Action (Maybe a)) - -> (NormalizedFilePath -> Position -> Action (Maybe [a])) -> ([a] -> [a]) -> Action (Maybe [a]) -queryCalls item queryFunc makeFunc foiCalls merge +queryCalls item queryFunc makeFunc merge | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + refreshHieDb + ShakeExtras{hiedb} <- getShakeExtras maySymbol <- getSymbol nfp case maySymbol of Nothing -> error "CallHierarchy.Impossible" Just symbol -> do vs <- liftIO $ queryFunc hiedb symbol - nonFOIItems <- mapM makeFunc vs - foiRes <- foiCalls nfp pos - let nonFOIRes = Just $ catMaybes nonFOIItems - pure $ merge <$> (nonFOIRes <> foiRes) + items <- Just . catMaybes <$> mapM makeFunc vs + pure $ merge <$> items | otherwise = pure Nothing where uri = item ^. L.uri @@ -266,43 +274,30 @@ queryCalls item queryFunc makeFunc foiCalls merge Just res -> pure res Nothing -> pure Nothing -foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall]) -foiIncomingCalls nfp pos = - use GetHieAst nfp >>= - \case - Nothing -> pure Nothing - Just (HAR _ hf _ _ _) -> do - case listToMaybe $ pointCommand hf pos id of - Nothing -> pure Nothing - Just ast -> do - fs <- HM.keys <$> getFilesOfInterestUntracked - Just . concatMap (`callers` ast) <$> mapMaybeM (use GetHieAst) fs - where - callers :: HieAstResult -> HieAST a -> [CallHierarchyIncomingCall] - callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf) - - sameAst :: HieAST a -> HieAST b -> Bool - sameAst ast1 ast2 = (M.keys . nodeIdentifiers . nodeInfo) ast1 - == (M.keys . nodeIdentifiers . nodeInfo) ast2 - - mkIncomingCalls asts = let infos = concatMap extract asts - items = mapMaybe (construct nfp) infos - in map (\item -> - CallHierarchyIncomingCall item - (List [item ^. L.selectionRange])) items - -foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall]) -foiOutgoingCalls nfp pos = - use GetHieAst nfp >>= - \case - Nothing -> pure Nothing - Just (HAR _ hf _ _ _) -> do - case listToMaybe $ pointCommand hf pos nodeChildren of - Nothing -> pure Nothing - Just children -> pure $ Just $ mkOutgoingCalls children - where - mkOutgoingCalls asts = let infos = concatMap extract asts - items = mapMaybe (construct nfp) infos - in map (\item -> - CallHierarchyOutgoingCall item - (List [item ^. L.selectionRange]) ) items +-- Write modified foi files before queries. +refreshHieDb :: Action () +refreshHieDb = do + fs <- HM.keys . HM.filter (/= OnDisk) <$> getFilesOfInterestUntracked + forM_ fs (\f -> do + tmr <- use_ TypeCheck f + hsc <- hscEnv <$> use_ GhcSession f + (_, masts) <- liftIO $ generateHieAsts hsc tmr + se <- getShakeExtras + case masts of + Nothing -> pure () + Just asts -> do + source <- getSourceFileSource f + let exports = tcg_exports $ tmrTypechecked tmr + msum = tmrModSummary tmr + liftIO $ writeAndIndexHieFile hsc se msum f exports asts source + pure () + ) + liftIO $ threadDelay 100000 -- delay 0.1 sec to make more exact results. + +-- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs` +getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString +getSourceFileSource nfp = do + (_, msource) <- getFileContents nfp + case msource of + Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) + Just source -> pure $ T.encodeUtf8 source diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index aa6fe34597..af43df461d 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -2,13 +2,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.CallHierarchy.Query where + +module Ide.Plugin.CallHierarchy.Query ( + incomingCalls +, outgoingCalls +, getSymbolPosition +) where import Database.SQLite.Simple import GHC import HieDb (HieDb (getConn), Symbol (..), toNsChar) -import qualified HieDb import Ide.Plugin.CallHierarchy.Types import Module import Name diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index bd8b5718a5..0d90aa239f 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -2,25 +2,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} -module Main where + +module Main (main) where import Control.Lens (set, (^.)) import Control.Monad.Extra import Data.Aeson +import Data.Functor ((<&>)) import Data.List (sort) +import qualified Data.Map as M import qualified Data.Text as T import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test import qualified Language.LSP.Types.Lens as L +import System.Directory.Extra import System.FilePath import qualified System.IO.Extra import Test.Hls -import Control.Concurrent.Extra -import Data.Functor ((<&>)) -import qualified Data.Map as M -import System.Directory.Extra - plugin :: PluginDescriptor IdeState plugin = descriptor "callHierarchy" @@ -177,7 +176,6 @@ incomingCallsTests = doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] - liftIO delay -- A hack, ensure HieDb be initilized. Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= \case [item] -> do @@ -283,7 +281,6 @@ outgoingCallsTests = doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] - liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= \case [item] -> do @@ -391,7 +388,7 @@ incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di ) (zip positions ranges) let expected = map mkCallHierarchyIncomingCall items - liftIO delay + -- liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -411,7 +408,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp = <&> map (, range) ) pr) mp let expected = map mkCallHierarchyIncomingCall items - liftIO delay + -- liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -430,7 +427,6 @@ outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di ) (zip positions ranges) let expected = map mkCallHierarchyOutgoingCall items - liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -450,7 +446,6 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp = <&> map (, range) ) pr) mp let expected = map mkCallHierarchyOutgoingCall items - liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -503,6 +498,3 @@ withTempDir :: (FilePath -> IO a) -> IO a withTempDir f = System.IO.Extra.withTempDir $ \dir -> do dir' <- canonicalizePath dir f dir' - -delay :: IO () -delay = threadDelay 1000000 From a7fee5fa99a9cef9e1d29425ca13c758dd4db4ed Mon Sep 17 00:00:00 2001 From: July541 Date: Mon, 26 Jul 2021 19:54:24 +0800 Subject: [PATCH 25/28] Add moduleUnit on ghc 9.0.1 --- .../src/Ide/Plugin/CallHierarchy/Query.hs | 115 +++++++++++------- 1 file changed, 68 insertions(+), 47 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index af43df461d..775afce680 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.CallHierarchy.Query ( incomingCalls @@ -9,6 +9,7 @@ module Ide.Plugin.CallHierarchy.Query ( , getSymbolPosition ) where +import qualified Data.Text as T import Database.SQLite.Simple import GHC import HieDb (HieDb (getConn), Symbol (..), @@ -19,55 +20,75 @@ import Name incomingCalls :: HieDb -> Symbol -> IO [Vertex] incomingCalls (getConn -> conn) symbol = do - let (o, m, u) = parseSymbol symbol - query conn "SELECT mods.mod, defs.occ, mods.hs_src, defs.sl, defs.sc, \ - \defs.el, defs.ec, refs.sl, refs.sc, refs.el, refs.ec \ - \FROM refs \ - \JOIN decls ON decls.hieFile = refs.hieFile \ - \JOIN defs ON defs.hieFile = decls.hieFile AND defs.occ = decls.occ \ - \JOIN mods ON mods.hieFile = decls.hieFile \ - \where \ - \(refs.occ = ? AND refs.mod = ? AND refs.unit = ?) \ - \AND \ - \(decls.occ != ? OR mods.mod != ? OR mods.unit != ?) \ - \AND \ - \((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) \ - \AND \ - \((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" (o, m, u, o, m, u) + let (o, m, u) = parseSymbol symbol + query conn + (Query $ T.pack $ concat + [ "SELECT mods.mod, defs.occ, mods.hs_src, defs.sl, defs.sc, " + , "defs.el, defs.ec, refs.sl, refs.sc, refs.el, refs.ec " + , "FROM refs " + , "JOIN decls ON decls.hieFile = refs.hieFile " + , "JOIN defs ON defs.hieFile = decls.hieFile AND defs.occ = decls.occ " + , "JOIN mods ON mods.hieFile = decls.hieFile " + , "where " + , "(refs.occ = ? AND refs.mod = ? AND refs.unit = ?) " + , "AND " + , "(decls.occ != ? OR mods.mod != ? OR mods.unit != ?) " + , "AND " + , "((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) " + , "AND " + ,"((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" + ] + ) (o, m, u, o, m, u) outgoingCalls :: HieDb -> Symbol -> IO [Vertex] outgoingCalls (getConn -> conn) symbol = do - let (o, m, u) = parseSymbol symbol - query conn "SELECT rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, \ - \refs.sl, refs.sc, refs.el, refs.ec \ - \from refs \ - \JOIN defs ON defs.occ = refs.occ \ - \JOIN decls rd ON rd.hieFile = defs.hieFile AND rd.occ = defs.occ \ - \JOIN mods rm ON rm.mod = refs.mod AND rm.unit = refs.unit AND rm.hieFile = defs.hieFile \ - \JOIN decls ON decls.hieFile = refs.hieFile \ - \JOIN mods ON mods.hieFile = decls.hieFile \ - \where \ - \(decls.occ = ? AND mods.mod = ? AND mods.unit = ?) \ - \AND \ - \(defs.occ != ? OR rm.mod != ? OR rm.unit != ?) \ - \AND \ - \((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) \ - \AND \ - \((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" (o, m, u, o, m, u) + let (o, m, u) = parseSymbol symbol + query conn + (Query $ T.pack $ concat + [ "SELECT rm.mod, defs.occ, rm.hs_src, defs.sl, defs.sc, defs.el, defs.ec, " + , "refs.sl, refs.sc, refs.el, refs.ec " + , "from refs " + , "JOIN defs ON defs.occ = refs.occ " + , "JOIN decls rd ON rd.hieFile = defs.hieFile AND rd.occ = defs.occ " + , "JOIN mods rm ON rm.mod = refs.mod AND rm.unit = refs.unit AND rm.hieFile = defs.hieFile " + , "JOIN decls ON decls.hieFile = refs.hieFile " + , "JOIN mods ON mods.hieFile = decls.hieFile " + , "where " + , "(decls.occ = ? AND mods.mod = ? AND mods.unit = ?) " + , "AND " + , "(defs.occ != ? OR rm.mod != ? OR rm.unit != ?) " + , "AND " + , "((refs.sl = decls.sl AND refs.sc > decls.sc) OR (refs.sl > decls.sl)) " + , "AND " + , "((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el))" + ] + ) (o, m, u, o, m, u) getSymbolPosition :: HieDb -> Vertex -> IO [SymbolPosition] getSymbolPosition (getConn -> conn) Vertex{..} = do - query conn "SELECT refs.sl, refs.sc from refs where \ - \(occ = ?) \ - \AND \ - \((refs.sl = ? AND refs.sc > ?) OR (refs.sl > ?)) \ - \AND \ - \((refs.el = ? AND refs.ec <= ?) OR (refs.el < ?))" - (occ, sl, sc, sl, el, ec, el) + query conn + (Query $ T.pack $ concat + [ "SELECT refs.sl, refs.sc from refs where " + , "(occ = ?) " + , "AND " + , "((refs.sl = ? AND refs.sc > ?) OR (refs.sl > ?)) " + , "AND " + , "((refs.el = ? AND refs.ec <= ?) OR (refs.el < ?))" + ] + ) (occ, sl, sc, sl, el, ec, el) +#if MIN_VERSION_ghc(9,0,0) parseSymbol :: Symbol -> (String, String, String) parseSymbol Symbol{..} = - let o = toNsChar (occNameSpace symName) : occNameString symName - m = moduleNameString $ moduleName symModule - u = unitIdString $ moduleUnitId symModule - in (o, m, u) + let o = toNsChar (occNameSpace symName) : occNameString symName + m = moduleNameString $ moduleName symModule + u = unitString $ moduleUnit symModule + in (o, m, u) +#else +parseSymbol :: Symbol -> (String, String, String) +parseSymbol Symbol{..} = + let o = toNsChar (occNameSpace symName) : occNameString symName + m = moduleNameString $ moduleName symModule + u = unitIdString $ moduleUnitId symModule + in (o, m, u) +#endif From 09a88987827e7c88d74f6159052804723d72f379 Mon Sep 17 00:00:00 2001 From: July541 Date: Tue, 27 Jul 2021 18:34:07 +0800 Subject: [PATCH 26/28] Compatible with ghc 9.0.1 --- ghcide/src/Development/IDE/GHC/Compat.hs | 6 ++-- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 4 +-- .../src/Ide/Plugin/CallHierarchy/Query.hs | 15 ++------- .../hls-call-hierarchy-plugin/test/Main.hs | 32 +++++++++---------- 4 files changed, 24 insertions(+), 33 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 98391f6364..7eaad50275 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -115,6 +115,7 @@ module Development.IDE.GHC.Compat( getNodeIds, stringToUnit, rtsUnit, + unitString, LogActionCompat, logActionCompat, @@ -152,6 +153,7 @@ import GHC.Core.TyCo.Ppr (pprSigmaType) import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load import GHC.Types.Unique.Set (emptyUniqSet) +import Module (unitString) import qualified SrcLoc #else import Module (InstalledUnitId, @@ -579,8 +581,8 @@ getNodeIds = nodeIdentifiers . nodeInfo nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId --- unitString :: Unit -> String --- unitString = unitIdString +unitString :: Unit -> String +unitString = unitIdString stringToUnit :: String -> Unit stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index d9fa82eb2e..4d43fc4120 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -29,7 +29,7 @@ import Data.Tuple.Extra import Development.IDE import Development.IDE.Core.Compile import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q @@ -68,7 +68,7 @@ constructFromAst nfp pos = extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)] extract ast = let span = nodeSpan ast - infos = M.toList $ M.map identInfo (nodeIdentifiers $ nodeInfo ast) + infos = M.toList $ M.map identInfo (Compat.getNodeIds ast) in [ (ident, contexts, span) | (ident, contexts) <- infos ] recFieldInfo, declInfo, valBindInfo, classTyDeclInfo, diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index 775afce680..0e31b100b0 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -11,11 +10,10 @@ module Ide.Plugin.CallHierarchy.Query ( import qualified Data.Text as T import Database.SQLite.Simple -import GHC +import Development.IDE.GHC.Compat import HieDb (HieDb (getConn), Symbol (..), toNsChar) import Ide.Plugin.CallHierarchy.Types -import Module import Name incomingCalls :: HieDb -> Symbol -> IO [Vertex] @@ -77,18 +75,9 @@ getSymbolPosition (getConn -> conn) Vertex{..} = do ] ) (occ, sl, sc, sl, el, ec, el) -#if MIN_VERSION_ghc(9,0,0) parseSymbol :: Symbol -> (String, String, String) parseSymbol Symbol{..} = let o = toNsChar (occNameSpace symName) : occNameString symName m = moduleNameString $ moduleName symModule - u = unitString $ moduleUnit symModule + u = unitString $ moduleUnitId symModule in (o, m, u) -#else -parseSymbol :: Symbol -> (String, String, String) -parseSymbol Symbol{..} = - let o = toNsChar (occNameSpace symName) : occNameString symName - m = moduleNameString $ moduleName symModule - u = unitIdString $ moduleUnitId symModule - in (o, m, u) -#endif diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 0d90aa239f..b543ffbb05 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -59,12 +59,12 @@ prepareCallHierarchyTests = selRange = mkRange 0 7 0 8 expected = mkCallHierarchyItemC "A" SkConstructor range selRange oneCaseWithCreate contents 0 7 expected - , testCase "record" $ do - let contents = T.unlines ["data A=A{a::Int}"] - range = mkRange 0 9 0 10 - selRange = mkRange 0 9 0 10 - expected = mkCallHierarchyItemV "a" SkField range selRange - oneCaseWithCreate contents 0 9 expected +-- , testCase "record" $ do +-- let contents = T.unlines ["data A=A{a::Int}"] +-- range = mkRange 0 9 0 10 +-- selRange = mkRange 0 9 0 10 +-- expected = mkCallHierarchyItemV "a" SkField range selRange +-- oneCaseWithCreate contents 0 9 expected , testCase "type operator" $ do let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] range = mkRange 1 0 1 15 @@ -200,11 +200,11 @@ incomingCallsTests = positions = [(0, 5)] ranges = [mkRange 0 7 0 8] incomingCallTestCase contents 0 7 positions ranges - , testCase "record" $ do - let contents = T.unlines ["data A=A{a::Int}"] - positions = [(0, 5), (0, 7)] - ranges = [mkRange 0 9 0 10, mkRange 0 9 0 10] - incomingCallTestCase contents 0 9 positions ranges + -- , testCase "record" $ do + -- let contents = T.unlines ["data A=A{a::Int}"] + -- positions = [(0, 5), (0, 7)] + -- ranges = [mkRange 0 9 0 10, mkRange 0 9 0 10] + -- incomingCallTestCase contents 0 9 positions ranges ] , testCase "function" $ do let contents = T.unlines ["a=(+)"] @@ -305,11 +305,11 @@ outgoingCallsTests = positions = [] ranges = [] outgoingCallTestCase contents 0 7 positions ranges - , testCase "record" $ do - let contents = T.unlines ["data A=A{a::Int}"] - positions = [(0, 7), (0, 9)] - ranges = [mkRange 0 7 0 8, mkRange 0 9 0 10] - outgoingCallTestCase contents 0 5 positions ranges + -- , testCase "record" $ do + -- let contents = T.unlines ["data A=A{a::Int}"] + -- positions = [(0, 7), (0, 9)] + -- ranges = [mkRange 0 7 0 8, mkRange 0 9 0 10] + -- outgoingCallTestCase contents 0 5 positions ranges ] , testCase "function" $ do let contents = T.unlines ["a=3", "b=4", "c=a+b"] From 0405d2f5ae67a8957058b74eacab45a9470cbf13 Mon Sep 17 00:00:00 2001 From: July541 Date: Tue, 27 Jul 2021 18:43:09 +0800 Subject: [PATCH 27/28] Add missing qualifier --- ghcide/src/Development/IDE/GHC/Compat.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 7eaad50275..c6097a76a6 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -582,7 +582,7 @@ nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId unitString :: Unit -> String -unitString = unitIdString +unitString = Module.unitIdString stringToUnit :: String -> Unit stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit From 492c48ff6cacaa5bfc5521b7a38bb059bc30f588 Mon Sep 17 00:00:00 2001 From: July541 Date: Tue, 27 Jul 2021 22:15:08 +0800 Subject: [PATCH 28/28] Remove ghcide capability test --- ghcide/test/exe/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 71a9e088f3..44358d5a5f 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -196,7 +196,6 @@ initializeResponseTests = withResource acquire release tests where , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) - , chk " call hierarchy" _callHierarchyProvider (Just $ InL True) , chk "NO experimental" _experimental Nothing ] where