diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 3d572eb28a..3b43a0edd7 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -201,6 +201,6 @@ jobs: name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}} name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" diff --git a/cabal.project b/cabal.project index e3464ab4dc..9343f9cd6f 100644 --- a/cabal.project +++ b/cabal.project @@ -88,17 +88,17 @@ allow-newer: source-repository-package type: git location: https://github.com/haskell/lsp.git - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdir: lsp-types source-repository-package type: git location: https://github.com/haskell/lsp.git - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdir: lsp-test source-repository-package type: git location: https://github.com/haskell/lsp.git - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96 subdir: lsp diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index b65e44a4db..2bfe7ac8f1 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -22,9 +22,11 @@ library build-depends: , aeson , base >=4.12 && <5 + , bytestring , containers , extra , ghc + , ghc-api-compat , ghcide >=1.2 && <1.5 , hiedb , hls-plugin-api ^>=1.1 diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 60f4380d29..ce21a79454 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -1,4 +1,4 @@ -module Ide.Plugin.CallHierarchy where +module Ide.Plugin.CallHierarchy (descriptor) where import Development.IDE import qualified Ide.Plugin.CallHierarchy.Internal as X diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 3c2ae2fb59..d9fa82eb2e 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -5,39 +5,42 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} + module Ide.Plugin.CallHierarchy.Internal ( prepareCallHierarchy , incomingCalls , outgoingCalls ) where +import Control.Concurrent import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson as A +import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM import Data.List (groupBy, sortBy) import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Tuple.Extra import Development.IDE +import Development.IDE.Core.Compile import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Spans.AtPoint -import Development.IDE.Spans.Common import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types import Ide.Types import Language.LSP.Types import qualified Language.LSP.Types.Lens as L -import Maybes import Name -import SrcLoc import Text.Read (readMaybe) +-- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state pluginId param | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = @@ -92,11 +95,11 @@ construct nfp (ident, contexts, ssp) | Just ctx <- declInfo contexts = Just $ case ctx of - Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp - Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp - Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp + Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp @@ -125,7 +128,7 @@ construct nfp (ident, contexts, ssp) mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem mkCallHierarchyItem nfp ident kind span selSpan = CallHierarchyItem - (T.pack $ identifierName ident) + (T.pack $ optimize $ identifierName ident) kind Nothing (Just $ T.pack $ identifierToDetail ident) @@ -144,12 +147,16 @@ mkCallHierarchyItem nfp ident kind span selSpan = Left modName -> moduleNameString modName Right name -> occNameString $ nameOccName name + optimize :: String -> String + optimize name -- optimize display for DuplicateRecordFields + | "$sel:" == take 5 name = drop 5 name + | otherwise = name + mkSymbol :: Identifier -> Maybe Symbol mkSymbol = \case Left _ -> Nothing Right name -> Just $ Symbol (occName name) (nameModule name) - ---------------------------------------------------------------------- -------------- Incoming calls and outgoing calls --------------------- ---------------------------------------------------------------------- @@ -158,11 +165,12 @@ deriving instance Ord SymbolKind deriving instance Ord SymbolTag deriving instance Ord CallHierarchyItem +-- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls incomingCalls state pluginId param = do liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall - foiIncomingCalls mergeIncomingCalls >>= + mergeIncomingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error" @@ -178,11 +186,12 @@ incomingCalls state pluginId param = do merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls in CallHierarchyIncomingCall (head calls ^. L.from) (List ranges) +-- Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls outgoingCalls state pluginId param = do liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall - foiOutgoingCalls mergeOutgoingCalls >>= + mergeOutgoingCalls >>= \case Just x -> pure $ Right $ Just $ List x Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error" @@ -223,21 +232,20 @@ queryCalls :: (Show a) => CallHierarchyItem -> (HieDb -> Symbol -> IO [Vertex]) -> (Vertex -> Action (Maybe a)) - -> (NormalizedFilePath -> Position -> Action (Maybe [a])) -> ([a] -> [a]) -> Action (Maybe [a]) -queryCalls item queryFunc makeFunc foiCalls merge +queryCalls item queryFunc makeFunc merge | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + refreshHieDb + ShakeExtras{hiedb} <- getShakeExtras maySymbol <- getSymbol nfp case maySymbol of Nothing -> error "CallHierarchy.Impossible" Just symbol -> do vs <- liftIO $ queryFunc hiedb symbol - nonFOIItems <- mapM makeFunc vs - foiRes <- foiCalls nfp pos - let nonFOIRes = Just $ catMaybes nonFOIItems - pure $ merge <$> (nonFOIRes <> foiRes) + items <- Just . catMaybes <$> mapM makeFunc vs + pure $ merge <$> items | otherwise = pure Nothing where uri = item ^. L.uri @@ -266,43 +274,30 @@ queryCalls item queryFunc makeFunc foiCalls merge Just res -> pure res Nothing -> pure Nothing -foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall]) -foiIncomingCalls nfp pos = - use GetHieAst nfp >>= - \case - Nothing -> pure Nothing - Just (HAR _ hf _ _ _) -> do - case listToMaybe $ pointCommand hf pos id of - Nothing -> pure Nothing - Just ast -> do - fs <- HM.keys <$> getFilesOfInterestUntracked - Just . concatMap (`callers` ast) <$> mapMaybeM (use GetHieAst) fs - where - callers :: HieAstResult -> HieAST a -> [CallHierarchyIncomingCall] - callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf) - - sameAst :: HieAST a -> HieAST b -> Bool - sameAst ast1 ast2 = (M.keys . nodeIdentifiers . nodeInfo) ast1 - == (M.keys . nodeIdentifiers . nodeInfo) ast2 - - mkIncomingCalls asts = let infos = concatMap extract asts - items = mapMaybe (construct nfp) infos - in map (\item -> - CallHierarchyIncomingCall item - (List [item ^. L.selectionRange])) items - -foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall]) -foiOutgoingCalls nfp pos = - use GetHieAst nfp >>= - \case - Nothing -> pure Nothing - Just (HAR _ hf _ _ _) -> do - case listToMaybe $ pointCommand hf pos nodeChildren of - Nothing -> pure Nothing - Just children -> pure $ Just $ mkOutgoingCalls children - where - mkOutgoingCalls asts = let infos = concatMap extract asts - items = mapMaybe (construct nfp) infos - in map (\item -> - CallHierarchyOutgoingCall item - (List [item ^. L.selectionRange]) ) items +-- Write modified foi files before queries. +refreshHieDb :: Action () +refreshHieDb = do + fs <- HM.keys . HM.filter (/= OnDisk) <$> getFilesOfInterestUntracked + forM_ fs (\f -> do + tmr <- use_ TypeCheck f + hsc <- hscEnv <$> use_ GhcSession f + (_, masts) <- liftIO $ generateHieAsts hsc tmr + se <- getShakeExtras + case masts of + Nothing -> pure () + Just asts -> do + source <- getSourceFileSource f + let exports = tcg_exports $ tmrTypechecked tmr + msum = tmrModSummary tmr + liftIO $ writeAndIndexHieFile hsc se msum f exports asts source + pure () + ) + liftIO $ threadDelay 100000 -- delay 0.1 sec to make more exact results. + +-- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs` +getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString +getSourceFileSource nfp = do + (_, msource) <- getFileContents nfp + case msource of + Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) + Just source -> pure $ T.encodeUtf8 source diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index aa6fe34597..af43df461d 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -2,13 +2,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.CallHierarchy.Query where + +module Ide.Plugin.CallHierarchy.Query ( + incomingCalls +, outgoingCalls +, getSymbolPosition +) where import Database.SQLite.Simple import GHC import HieDb (HieDb (getConn), Symbol (..), toNsChar) -import qualified HieDb import Ide.Plugin.CallHierarchy.Types import Module import Name diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index bd8b5718a5..0d90aa239f 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -2,25 +2,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} -module Main where + +module Main (main) where import Control.Lens (set, (^.)) import Control.Monad.Extra import Data.Aeson +import Data.Functor ((<&>)) import Data.List (sort) +import qualified Data.Map as M import qualified Data.Text as T import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test import qualified Language.LSP.Types.Lens as L +import System.Directory.Extra import System.FilePath import qualified System.IO.Extra import Test.Hls -import Control.Concurrent.Extra -import Data.Functor ((<&>)) -import qualified Data.Map as M -import System.Directory.Extra - plugin :: PluginDescriptor IdeState plugin = descriptor "callHierarchy" @@ -177,7 +176,6 @@ incomingCallsTests = doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] - liftIO delay -- A hack, ensure HieDb be initilized. Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= \case [item] -> do @@ -283,7 +281,6 @@ outgoingCallsTests = doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] - liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= \case [item] -> do @@ -391,7 +388,7 @@ incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di ) (zip positions ranges) let expected = map mkCallHierarchyIncomingCall items - liftIO delay + -- liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -411,7 +408,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp = <&> map (, range) ) pr) mp let expected = map mkCallHierarchyIncomingCall items - liftIO delay + -- liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -430,7 +427,6 @@ outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di ) (zip positions ranges) let expected = map mkCallHierarchyOutgoingCall items - liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -450,7 +446,6 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp = <&> map (, range) ) pr) mp let expected = map mkCallHierarchyOutgoingCall items - liftIO delay Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> do @@ -503,6 +498,3 @@ withTempDir :: (FilePath -> IO a) -> IO a withTempDir f = System.IO.Extra.withTempDir $ \dir -> do dir' <- canonicalizePath dir f dir' - -delay :: IO () -delay = threadDelay 1000000