hls-call-hierarchy-plugin (empty) → 1.0.0.0
raw patch · 10 files changed
+1248/−0 lines, 10 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, extra, filepath, ghc, ghc-api-compat, ghcide, hiedb, hls-call-hierarchy-plugin, hls-plugin-api, hls-test-utils, lens, lsp, lsp-test, sqlite-simple, text, unordered-containers
Files
- LICENSE +201/−0
- hls-call-hierarchy-plugin.cabal +78/−0
- src/Ide/Plugin/CallHierarchy.hs +13/−0
- src/Ide/Plugin/CallHierarchy/Internal.hs +303/−0
- src/Ide/Plugin/CallHierarchy/Query.hs +83/−0
- src/Ide/Plugin/CallHierarchy/Types.hs +47/−0
- test/Main.hs +500/−0
- test/testdata/A.hs +11/−0
- test/testdata/B.hs +7/−0
- test/testdata/C.hs +5/−0
+ LICENSE view
@@ -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.
+ hls-call-hierarchy-plugin.cabal view
@@ -0,0 +1,78 @@+cabal-version: 2.4+name: hls-call-hierarchy-plugin+version: 1.0.0.0+synopsis: Call hierarchy plugin for Haskell Language Server+description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-call-hierarchy-plugin#readme>++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 >=1.5.2.0+ , base >=4.12 && <5+ , bytestring+ , containers+ , extra+ , ghc+ , ghcide ^>=1.4.1+ , hiedb+ , hls-plugin-api ^>=1.2+ , lens+ , lsp >=1.2.0.1+ , sqlite-simple+ , text+ , unordered-containers++ default-language: Haskell2010+ default-extensions: DataKinds++ if impl(ghc < 8.10.5)+ build-depends:+ ghc-api-compat ==8.6+ elif impl(ghc == 8.10.5)+ build-depends:+ ghc-api-compat ==8.10.5+ elif impl(ghc == 8.10.6)+ build-depends:+ ghc-api-compat ==8.10.6+ elif impl(ghc == 8.10.7)+ build-depends:+ ghc-api-compat ==8.10.7+ elif impl(ghc == 9.0.1)+ build-depends:+ ghc-api-compat ==9.0.1++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 && <1.2+ , lens+ , lsp+ , lsp-test+ , text
+ src/Ide/Plugin/CallHierarchy.hs view
@@ -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+ }
+ src/Ide/Plugin/CallHierarchy/Internal.hs view
@@ -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
+ src/Ide/Plugin/CallHierarchy/Query.hs view
@@ -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)
+ src/Ide/Plugin/CallHierarchy/Types.hs view
@@ -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
+ test/Main.hs view
@@ -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'
+ test/testdata/A.hs view
@@ -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
+ test/testdata/B.hs view
@@ -0,0 +1,7 @@+module B where+import qualified C+data T = A | B++a = 3 + C.a+b = 4+c = 5
+ test/testdata/C.hs view
@@ -0,0 +1,5 @@+module C where++a = 3+b = 4+c = 5