diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/hls-call-hierarchy-plugin.cabal b/hls-call-hierarchy-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-call-hierarchy-plugin.cabal @@ -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 + +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 diff --git a/src/Ide/Plugin/CallHierarchy.hs b/src/Ide/Plugin/CallHierarchy.hs new file mode 100644 --- /dev/null +++ b/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/src/Ide/Plugin/CallHierarchy/Internal.hs b/src/Ide/Plugin/CallHierarchy/Internal.hs new file mode 100644 --- /dev/null +++ b/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/src/Ide/Plugin/CallHierarchy/Query.hs b/src/Ide/Plugin/CallHierarchy/Query.hs new file mode 100644 --- /dev/null +++ b/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/src/Ide/Plugin/CallHierarchy/Types.hs b/src/Ide/Plugin/CallHierarchy/Types.hs new file mode 100644 --- /dev/null +++ b/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/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/A.hs b/test/testdata/A.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/B.hs b/test/testdata/B.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/C.hs b/test/testdata/C.hs new file mode 100644 --- /dev/null +++ b/test/testdata/C.hs @@ -0,0 +1,5 @@ +module C where + +a = 3 +b = 4 +c = 5