diff --git a/hls-call-hierarchy-plugin.cabal b/hls-call-hierarchy-plugin.cabal --- a/hls-call-hierarchy-plugin.cabal +++ b/hls-call-hierarchy-plugin.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/CallHierarchy.hs b/src/Ide/Plugin/CallHierarchy.hs --- a/src/Ide/Plugin/CallHierarchy.hs +++ b/src/Ide/Plugin/CallHierarchy.hs @@ -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 + } diff --git a/src/Ide/Plugin/CallHierarchy/Internal.hs b/src/Ide/Plugin/CallHierarchy/Internal.hs --- a/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -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 diff --git a/src/Ide/Plugin/CallHierarchy/Types.hs b/src/Ide/Plugin/CallHierarchy/Types.hs --- a/src/Ide/Plugin/CallHierarchy/Types.hs +++ b/src/Ide/Plugin/CallHierarchy/Types.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 +