diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index bb73c81969..3b43a0edd7 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -200,3 +200,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}} + 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 966fbf63ee..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 * diff --git a/cabal.project b/cabal.project index 0b4b5d7093..9343f9cd6f 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 * @@ -84,3 +85,20 @@ allow-newer: these:base, time-compat:base +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdir: lsp-types + +source-repository-package + type: git + location: https://github.com/haskell/lsp.git + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdir: lsp-test + +source-repository-package + type: git + location: https://github.com/haskell/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/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 0bc0204821..d5e8dd9e29 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -114,6 +114,7 @@ module Development.IDE.GHC.Compat( getNodeIds, stringToUnit, rtsUnit, + unitString, LogActionCompat, logActionCompat, @@ -151,6 +152,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, @@ -578,8 +580,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 = Module.unitIdString stringToUnit :: String -> Unit stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 7842ef76e1..297a788176 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 @@ -426,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) 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 c2c6da2454..7eb109f199 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -255,6 +255,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 @@ -452,6 +461,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/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 new file mode 100644 index 0000000000..2bfe7ac8f1 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -0,0 +1,60 @@ +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: + LICENSE + test/testdata/*.hs + +library + exposed-modules: Ide.Plugin.CallHierarchy + other-modules: + Ide.Plugin.CallHierarchy.Internal + Ide.Plugin.CallHierarchy.Query + Ide.Plugin.CallHierarchy.Types + hs-source-dirs: src + 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 + , lens + , lsp + , sqlite-simple + , text + , unordered-containers + + 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: + , aeson + , base + , containers + , extra + , filepath + , 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.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs new file mode 100644 index 0000000000..ce21a79454 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -0,0 +1,13 @@ +module Ide.Plugin.CallHierarchy (descriptor) 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 new file mode 100644 index 0000000000..4d43fc4120 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 as 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) + +-- | Render prepare call hierarchy request. +prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy +prepareCallHierarchy state pluginId param + | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = + liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem 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 :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +prepareCallHierarchyItem = constructFromAst + +constructFromAst :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem]) +constructFromAst 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 (Compat.getNodeIds ast) + in [ (ident, contexts, span) | (ident, contexts) <- infos ] + +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 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 +construct nfp (ident, contexts, ssp) + | isInternalIdentifier ident = Nothing + + | 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 + 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 + + | 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 + + isInternalIdentifier = \case + Left _ -> False + Right name -> isInternalName name + +mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem +mkCallHierarchyItem nfp ident kind span selSpan = + CallHierarchyItem + (T.pack $ optimize $ identifierName ident) + kind + Nothing + (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 + + identifierName :: Identifier -> String + identifierName = \case + 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 --------------------- +---------------------------------------------------------------------- + +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 + mergeIncomingCalls >>= + \case + Just x -> pure $ Right $ Just $ List x + Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error" + where + 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) + +-- 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 + mergeOutgoingCalls >>= + \case + Just x -> pure $ Right $ Just $ List x + Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error" + where + mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) + mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall + + 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 mk v@Vertex{..} = do + let pos = Position (sl - 1) (sc - 1) + nfp = toNormalizedFilePath' hieSrc + range = mkRange (casl - 1) (casc - 1) (cael - 1) (caec - 1) + + 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]) + -> (Vertex -> Action (Maybe a)) + -> ([a] -> [a]) + -> Action (Maybe [a]) +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 + items <- Just . catMaybes <$> mapM makeFunc vs + pure $ merge <$> items + | 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 + 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 + + 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 mkSymbol . fst3 <$> listToMaybe infos of + Nothing -> pure Nothing + Just res -> pure res + Nothing -> pure Nothing + +-- 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 new file mode 100644 index 0000000000..0e31b100b0 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.CallHierarchy.Query ( + incomingCalls +, outgoingCalls +, getSymbolPosition +) where + +import qualified Data.Text as T +import Database.SQLite.Simple +import Development.IDE.GHC.Compat +import HieDb (HieDb (getConn), Symbol (..), + toNsChar) +import Ide.Plugin.CallHierarchy.Types +import Name + +incomingCalls :: HieDb -> Symbol -> IO [Vertex] +incomingCalls (getConn -> conn) symbol = do + 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 + (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 + (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) + +parseSymbol :: Symbol -> (String, String, String) +parseSymbol Symbol{..} = + let o = toNsChar (occNameSpace symName) : occNameString symName + m = moduleNameString $ moduleName symModule + u = unitString $ moduleUnitId symModule + in (o, m, u) 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..0c10d95ca0 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Types.hs @@ -0,0 +1,47 @@ +{-# 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 +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 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..b543ffbb05 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +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 + +plugin :: PluginDescriptor IdeState +plugin = descriptor "callHierarchy" + +main :: IO () +main = defaultTestRunner $ + testGroup "Call Hierarchy" + [ prepareCallHierarchyTests + , incomingCallsTests + , outgoingCallsTests + ] + +prepareCallHierarchyTests :: TestTree +prepareCallHierarchyTests = + testGroup + "Prepare Call Hierarchy" + [ testCase "variable" $ do + let contents = T.unlines ["a=3"] + range = mkRange 0 0 0 3 + selRange = mkRange 0 0 0 1 + 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 = 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 = 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 = 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 "type operator" $ do + let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] + range = mkRange 1 0 1 15 + selRange = mkRange 1 5 1 9 + 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 = 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 = mkCallHierarchyItemV "a" SkMethod range selRange + oneCaseWithCreate contents 0 16 expected + , 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 + 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 = 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 = mkCallHierarchyItemT "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 23 + 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 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 + selRange = mkRange 0 5 0 6 + 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 = 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 = mkCallHierarchyItemT "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 = mkCallHierarchyItemC "A" SkConstructor range selRange + oneCaseWithCreate contents 1 13 expected + ] + +incomingCallsTests :: TestTree +incomingCallsTests = + testGroup "Incoming Calls" + [ testGroup "single file" + [ + 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])] + 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 available" $ do + let contents = T.unlines ["a=3","b=a"] + positions = [(1, 0)] + ranges = [mkRange 1 2 1 3] + incomingCallTestCase contents 0 1 positions ranges + , testGroup "data" + [ testCase "data type" $ do + 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"] + 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])] + 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 + +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) + 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 + +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 + 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 + 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" + closeDoc doc + +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" + +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" + +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 + +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' 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..c31455d63b --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/A.hs @@ -0,0 +1,11 @@ +module A where +import B +import C + +foo1 = B.a + C.a +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 new file mode 100644 index 0000000000..44a7fc9504 --- /dev/null +++ b/plugins/hls-call-hierarchy-plugin/test/testdata/B.hs @@ -0,0 +1,7 @@ +module B where +import qualified C +data T = A | B + +a = 3 + C.a +b = 4 +c = 5 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..ab7d2158ae --- /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 diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 61b5dd3925..58e1eb6263 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 @@ -44,9 +45,6 @@ extra-deps: - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-source-gen-0.4.1.0 - - 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.5 @@ -68,6 +66,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # https://github.com/haskell/lsp/pull/332 + configure-options: $targets: - --enable-executable-dynamic diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index fc87207cf2..ba3c3698e0 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 @@ -58,9 +59,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 +66,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # https://github.com/haskell/lsp/pull/332 + configure-options: $targets: - --enable-executable-dynamic diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index e4d7a644c5..4968bbee03 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 @@ -54,9 +55,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 +62,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # 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 af7916eb87..323c2371c9 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 @@ -56,9 +57,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 +64,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # 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 ea8747546a..c838b35967 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 @@ -94,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 @@ -105,6 +103,14 @@ extra-deps: - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # 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 658f601de0..0aefc1f9bb 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 @@ -95,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 @@ -106,6 +104,14 @@ extra-deps: - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 - resourcet-1.2.3 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # https://github.com/haskell/lsp/pull/332 + configure-options: $targets: - --enable-executable-dynamic diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index c613efb012..f51324d932 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 @@ -75,9 +76,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 +83,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # https://github.com/haskell/lsp/pull/332 + configure-options: $targets: - --enable-executable-dynamic diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 24b4499899..cba8cc6e11 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 @@ -72,9 +73,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 +80,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # https://github.com/haskell/lsp/pull/332 + configure-options: $targets: - --enable-executable-dynamic diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 646ebc4049..86d074ff75 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 ddf460a877..192b8dd825 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 @@ -51,9 +52,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 +59,14 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + - github: haskell/lsp + commit: ef59c28b41ed4c5775f0ab0c1e985839359cec96 + subdirs: + - lsp-types + - lsp + - lsp-test + # https://github.com/haskell/lsp/pull/332 + configure-options: $targets: - --enable-executable-dynamic