hls-call-hierarchy-plugin 1.1.0.0 → 1.2.0.0
raw patch · 5 files changed
+229/−237 lines, 5 filesdep +ghcide-test-utilsdep −bytestringdep −ghcdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependencies added: ghcide-test-utils
Dependencies removed: bytestring, ghc
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
- Ide.Plugin.CallHierarchy: descriptor :: PluginDescriptor IdeState
+ Ide.Plugin.CallHierarchy: descriptor :: PluginId -> PluginDescriptor IdeState
Files
- hls-call-hierarchy-plugin.cabal +9/−6
- src/Ide/Plugin/CallHierarchy.hs +7/−6
- src/Ide/Plugin/CallHierarchy/Internal.hs +168/−194
- src/Ide/Plugin/CallHierarchy/Types.hs +19/−19
- test/Main.hs +26/−12
hls-call-hierarchy-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-call-hierarchy-plugin-version: 1.1.0.0+version: 1.2.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>@@ -15,6 +15,10 @@ LICENSE test/testdata/*.hs +source-repository head+ type: git+ location: https://github.com/haskell/haskell-language-server.git+ library buildable: True exposed-modules: Ide.Plugin.CallHierarchy@@ -27,13 +31,11 @@ build-depends: , aeson , base >=4.12 && <5- , bytestring , containers , extra- , ghc- , ghcide ^>= 1.8+ , ghcide ^>= 1.9 , hiedb- , hls-plugin-api ^>= 1.5+ , hls-plugin-api ^>= 1.6 , lens , lsp >=1.2.0.1 , sqlite-simple@@ -57,7 +59,8 @@ , extra , filepath , hls-call-hierarchy-plugin- , hls-test-utils ^>=1.4+ , hls-test-utils ^>=1.5+ , ghcide-test-utils , lens , lsp , lsp-test
src/Ide/Plugin/CallHierarchy.hs view
@@ -5,9 +5,10 @@ import Ide.Types import Language.LSP.Types -descriptor :: PluginDescriptor IdeState-descriptor = (defaultPluginDescriptor X.callHierarchyId)- { Ide.Types.pluginHandlers = mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy- <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls- <> mkPluginHandler SCallHierarchyOutgoingCalls X.outgoingCalls- }+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
@@ -11,28 +11,21 @@ prepareCallHierarchy , incomingCalls , outgoingCalls-, callHierarchyId ) where 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 GHC.Conc.Sync import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types@@ -44,44 +37,33 @@ import qualified Language.LSP.Types.Lens as L import Text.Read (readMaybe) -callHierarchyId :: PluginId-callHierarchyId = PluginId "callHierarchy"- -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy prepareCallHierarchy state _ param = pluginResponse $ do nfp <- getNormalizedFilePath (param ^. L.textDocument ^. L.uri)- items <- liftIO (runAction "CallHierarchy.prepareHierarchy" state (prepareCallHierarchyItem nfp (param ^. L.position)))- pure (List <$> items)--prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem])-prepareCallHierarchyItem = constructFromAst+ items <- liftIO+ $ runAction "CallHierarchy.prepareHierarchy" state+ $ prepareCallHierarchyItem nfp (param ^. L.position)+ pure $ List <$> pure items -constructFromAst :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyItem])-constructFromAst nfp pos =- use GetHieAst nfp >>=- \case- Nothing -> pure Nothing- Just (HAR _ hf _ _ _) -> do- resolveIntoCallHierarchy hf pos nfp+prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]+prepareCallHierarchyItem nfp pos = use GetHieAst nfp >>= \case+ Nothing -> pure mempty+ Just (HAR _ hf _ _ _) -> pure $ prepareByAst hf pos nfp -resolveIntoCallHierarchy :: Applicative f => HieASTs a -> Position -> NormalizedFilePath -> f (Maybe [CallHierarchyItem])-resolveIntoCallHierarchy hf pos nfp =- case listToMaybe $ pointCommand hf pos extract of- Nothing -> pure Nothing- Just infos ->- case mapMaybe (construct nfp hf) infos of- [] -> pure Nothing- res -> pure $ Just res+prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]+prepareByAst hf pos nfp =+ case listToMaybe $ pointCommand hf pos extract of+ Nothing -> mempty+ Just infos -> mapMaybe (construct nfp hf) infos -extract :: HieAST a -> [(Identifier, S.Set ContextInfo, Span)]+extract :: HieAST a -> [(Identifier, [ContextInfo], Span)] extract ast = let span = nodeSpan ast- infos = M.toList $ M.map identInfo (Compat.getNodeIds ast)- in [ (ident, contexts, span) | (ident, contexts) <- infos ]+ infos = M.toList $ M.map (S.toList . identInfo) (Compat.getNodeIds ast)+ in [(ident, contexts, span) | (ident, contexts) <- infos] recFieldInfo, declInfo, valBindInfo, classTyDeclInfo,- useInfo, patternBindInfo, tyDeclInfo, matchBindInfo- :: [ContextInfo] -> Maybe ContextInfo+ useInfo, patternBindInfo, tyDeclInfo, matchBindInfo :: [ContextInfo] -> Maybe ContextInfo recFieldInfo ctxs = listToMaybe [ctx | ctx@RecField{} <- ctxs] declInfo ctxs = listToMaybe [ctx | ctx@Decl{} <- ctxs] valBindInfo ctxs = listToMaybe [ctx | ctx@ValBind{} <- ctxs]@@ -91,98 +73,93 @@ tyDeclInfo ctxs = listToMaybe [TyDecl | TyDecl <- ctxs] matchBindInfo ctxs = listToMaybe [MatchBind | MatchBind <- ctxs] -construct :: NormalizedFilePath -> HieASTs a -> (Identifier, S.Set ContextInfo, Span) -> Maybe CallHierarchyItem+construct :: NormalizedFilePath -> HieASTs a -> (Identifier, [ContextInfo], Span) -> Maybe CallHierarchyItem construct nfp hf (ident, contexts, ssp)- | isInternalIdentifier ident = Nothing-- | Just (RecField RecFieldDecl _) <- recFieldInfo ctxList- -- ignored type span- = Just $ mkCallHierarchyItem' ident SkField ssp ssp+ | isInternalIdentifier ident = Nothing - | isJust (matchBindInfo ctxList) && isNothing (valBindInfo ctxList)- = Just $ mkCallHierarchyItem' ident SkFunction ssp ssp+ | Just (RecField RecFieldDecl _) <- recFieldInfo contexts+ -- ignored type span+ = Just $ mkCallHierarchyItem' ident SkField ssp ssp - | Just ctx <- valBindInfo ctxList- = Just $ case ctx of- ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp- _ -> mkCallHierarchyItem' ident skUnknown ssp ssp+ | isJust (matchBindInfo contexts) && isNothing (valBindInfo contexts)+ = Just $ mkCallHierarchyItem' ident SkFunction ssp ssp - | Just ctx <- declInfo ctxList- = 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 ctx <- valBindInfo contexts+ = Just $ case ctx of+ ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp+ _ -> mkCallHierarchyItem' ident skUnknown ssp ssp - | Just (ClassTyDecl span) <- classTyDeclInfo ctxList- = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) 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 (PatternBind _ _ span) <- patternBindInfo ctxList- = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp+ | Just (ClassTyDecl span) <- classTyDeclInfo contexts+ = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) ssp - | Just Use <- useInfo ctxList- = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp+ | Just (PatternBind _ _ span) <- patternBindInfo contexts+ = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - | Just _ <- tyDeclInfo ctxList- = renderTyDecl+ | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp - | otherwise = Nothing- where- renderSpan = \case Just span -> span- _ -> ssp+ | Just _ <- tyDeclInfo contexts = renderTyDecl - skUnknown = SkUnknown 27+ | otherwise = Nothing+ where+ renderSpan (Just span) = span+ renderSpan _ = ssp - mkCallHierarchyItem' = mkCallHierarchyItem nfp+ -- https://github.com/haskell/lsp/blob/e11b7c09658610f6d815d04db08a64e7cf6b4467/lsp-types/src/Language/LSP/Types/DocumentSymbol.hs#L97+ skUnknown = SkUnknown 27 -- 27 is the first unused number while ToJSON - isInternalIdentifier = \case- Left _ -> False- Right name -> isInternalName name+ mkCallHierarchyItem' = mkCallHierarchyItem nfp - ctxList = S.toList contexts+ isInternalIdentifier = \case+ Left _ -> False+ Right name -> isInternalName name - renderTyDecl = case ident of- Left _ -> Nothing- Right name -> case getNameBindingInClass name ssp (getAsts hf) of- Nothing -> Nothing- Just sp -> case resolveIntoCallHierarchy hf (realSrcSpanToRange sp ^. L.start) nfp of- Just (Just items) -> listToMaybe items- _ -> Nothing+ renderTyDecl = case ident of+ Left _ -> Nothing+ Right name -> case getNameBinding name (getAsts hf) of+ Nothing -> Nothing+ Just sp -> listToMaybe $ prepareByAst hf (realSrcSpanToRange sp ^. L.start) nfp 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+ CallHierarchyItem+ (T.pack $ optimizeDisplay $ 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+ 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+ optimizeDisplay :: String -> String+ optimizeDisplay 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)+ Left _ -> Nothing+ Right name -> Just $ Symbol (occName name) (nameModule name) ---------------------------------------------------------------------- -------------- Incoming calls and outgoing calls ---------------------@@ -198,106 +175,103 @@ -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls incomingCalls state pluginId param = pluginResponse $ do- calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $- queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall- mergeIncomingCalls- case calls of- Just x -> pure $ Just $ List x- Nothing -> throwPluginError "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)+ calls <- liftIO+ $ runAction "CallHierarchy.incomingCalls" state+ $ queryCalls+ (param ^. L.item)+ Q.incomingCalls+ mkCallHierarchyIncomingCall+ (mergeCalls CallHierarchyIncomingCall L.from)+ pure $ Just $ List calls+ where+ mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)+ mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall --- Render outgoing calls request.+-- | Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls outgoingCalls state pluginId param = pluginResponse $ do- calls <- liftIO $ runAction "CallHierarchy.outgoingCalls" state $- queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall- mergeOutgoingCalls- case calls of- Just x -> pure $ Just $ List x- Nothing -> throwPluginError "outgoingCalls - Internal Error"- where- mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)- mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall+ calls <- liftIO+ $ runAction "CallHierarchy.outgoingCalls" state+ $ queryCalls+ (param ^. L.item)+ Q.outgoingCalls+ mkCallHierarchyOutgoingCall+ (mergeCalls CallHierarchyOutgoingCall L.to)+ pure $ Just $ List calls+ 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)+-- | Merge calls from the same place+mergeCalls constructor target =+ concatMap merge+ . groupBy (\a b -> a ^. target == b ^. target)+ . sortBy (\a b -> (a ^. target) `compare` (b ^. target))+ where+ merge [] = []+ merge calls@(call:_) =+ let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls+ in [constructor (call ^. target) (List ranges)] mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) mkCallHierarchyCall mk v@Vertex{..} = do- let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1)- nfp = toNormalizedFilePath' hieSrc- range = mkRange (fromIntegral $ casl - 1) (fromIntegral $ casc - 1) (fromIntegral $ cael - 1) (fromIntegral $ caec - 1)+ let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1)+ nfp = toNormalizedFilePath' hieSrc+ range = mkRange+ (fromIntegral $ casl - 1)+ (fromIntegral $ casc - 1)+ (fromIntegral $ cael - 1)+ (fromIntegral $ caec - 1) - prepareCallHierarchyItem nfp pos >>=- \case- Just [item] -> pure $ Just $ mk item (List [range])- _ -> do- ShakeExtras{withHieDb} <- getShakeExtras- liftIO (withHieDb (`Q.getSymbolPosition` v)) >>=- \case- (x:_) ->- prepareCallHierarchyItem nfp (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) >>=- \case- Just [item] -> pure $ Just $ mk item (List [range])- _ -> pure Nothing- _ -> pure Nothing+ prepareCallHierarchyItem nfp pos >>=+ \case+ [item] -> pure $ Just $ mk item (List [range])+ _ -> do+ ShakeExtras{withHieDb} <- getShakeExtras+ sps <- liftIO (withHieDb (`Q.getSymbolPosition` v))+ case sps of+ (x:_) -> do+ items <- prepareCallHierarchyItem+ nfp+ (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1))+ case items of+ [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])+ => CallHierarchyItem+ -> (HieDb -> Symbol -> IO [Vertex])+ -> (Vertex -> Action (Maybe a))+ -> ([a] -> [a])+ -> Action [a] queryCalls item queryFunc makeFunc merge- | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do- ShakeExtras{withHieDb} <- getShakeExtras- maySymbol <- getSymbol nfp- case maySymbol of- Nothing -> error "CallHierarchy.Impossible"- Just symbol -> do- vs <- liftIO $ withHieDb (`queryFunc` 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)+ | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do+ ShakeExtras{withHieDb} <- getShakeExtras+ maySymbol <- getSymbol nfp+ case maySymbol of+ Nothing -> pure mempty+ Just symbol -> do+ vs <- liftIO $ withHieDb (`queryFunc` symbol)+ items <- catMaybes <$> mapM makeFunc vs+ pure $ merge items+ | otherwise = pure mempty+ 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+ getSymbol nfp = case item ^. L.xdata of+ Just xdata -> case fromJSON xdata of+ A.Success (symbolStr :: String) -> maybe (getSymbolFromAst nfp pos) (pure . pure) $ readMaybe symbolStr+ A.Error _ -> getSymbolFromAst nfp pos+ Nothing -> getSymbolFromAst nfp pos -- Fallback if xdata lost, some editor(VSCode) will drop it - 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+ 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 -> maybe (pure Nothing) pure $ mkSymbol . fst3 <$> listToMaybe infos+ Nothing -> pure Nothing
src/Ide/Plugin/CallHierarchy/Types.hs view
@@ -13,28 +13,28 @@ 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+, sl :: Int -- ^ start line+, sc :: Int -- ^ start character+, el :: Int -- ^ end line+, ec :: Int -- ^ end character+, 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- ]+ 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+ fromRow = Vertex <$> field <*> field <*> field+ <*> field <*> field <*> field+ <*> field <*> field <*> field+ <*> field <*> field data SymbolPosition = SymbolPosition { psl :: Int@@ -42,7 +42,7 @@ } deriving (Eq, Show, Generic, FromJSON, ToJSON) instance ToRow SymbolPosition where- toRow (SymbolPosition a b) = toRow (a, b)+ toRow (SymbolPosition a b) = toRow (a, b) instance FromRow SymbolPosition where- fromRow = SymbolPosition <$> field <*> field+ fromRow = SymbolPosition <$> field <*> field
test/Main.hs view
@@ -9,20 +9,21 @@ import Control.Monad.Extra import Data.Aeson import Data.Functor ((<&>))-import Data.List (sort)+import Data.List (sort, tails) 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 Development.IDE.Test import System.Directory.Extra import System.FilePath import qualified System.IO.Extra import Test.Hls import Test.Hls.Util (withCanonicalTempDir) -plugin :: PluginDescriptor IdeState-plugin = descriptor+plugin :: PluginTestDescriptor ()+plugin = mkPluginTestDescriptor' descriptor "call-hierarchy" main :: IO () main = defaultTestRunner $@@ -166,13 +167,13 @@ expected = mkCallHierarchyItemC "A" SkConstructor range selRange oneCaseWithCreate contents 1 13 expected , testGroup "type signature"- [ knownBrokenForGhcVersions [GHC94] "type signature broken" $ testCase "next line" $ do+ [ testCase "next line" $ do let contents = T.unlines ["a::Int", "a=3"] range = mkRange 1 0 1 3 selRange = mkRange 1 0 1 1 expected = mkCallHierarchyItemV "a" SkFunction range selRange oneCaseWithCreate contents 0 0 expected- , knownBrokenForGhcVersions [GHC94] "type signature broken" $ testCase "multi functions" $ do+ , testCase "multi functions" $ do let contents = T.unlines [ "a,b::Int", "a=3", "b=4"] range = mkRange 2 0 2 3 selRange = mkRange 2 0 2 1@@ -198,7 +199,7 @@ testCase "xdata unavailable" $ runSessionWithServer plugin testDataDir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]- waitForKickDone+ waitForIndex (testDataDir </> "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>=@@ -323,7 +324,7 @@ testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]- waitForKickDone+ waitForIndex (dir </> "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>=@@ -427,7 +428,7 @@ incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents- waitForKickDone+ waitForIndex (dir </> "A.hs") items <- concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) <&> map (, range)@@ -447,7 +448,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp = runSessionWithServer plugin testDataDir $ do doc <- openDoc filepath "haskell"- waitForKickDone+ waitForIndex (testDataDir </> filepath) items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do p <- openDoc fp "haskell" waitForKickDone@@ -469,7 +470,7 @@ outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents- waitForKickDone+ waitForIndex (dir </> "A.hs") items <- concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) <&> map (, range)@@ -488,7 +489,7 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp = runSessionWithServer plugin testDataDir $ do doc <- openDoc filepath "haskell"- waitForKickDone+ waitForIndex (testDataDir </> filepath) items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do p <- openDoc fp "haskell" waitForKickDone@@ -509,7 +510,7 @@ oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents- waitForKickDone+ waitForIndex (dir </> "A.hs") Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> liftIO $ item @?= expected (doc ^. L.uri)@@ -545,3 +546,16 @@ mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing++-- Wait for a special test message emitted by ghcide when a file is indexed,+-- so that call hierarchy can safely query the database.+waitForIndex :: FilePath -> Session ()+waitForIndex fp1 = skipManyTill anyMessage $ void $ referenceReady lenientEquals+ where+ -- fp1 may be relative, in that case we check that it is a suffix of the+ -- filepath from the message+ lenientEquals :: FilePath -> Bool+ lenientEquals fp2+ | isRelative fp1 = any (equalFilePath fp1) (map (foldr (</>) "") $ tails $ splitDirectories fp2)+ | otherwise = equalFilePath fp1 fp2+