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.0.3.0 +version: 1.1.0.0 synopsis: Call hierarchy plugin for Haskell Language Server description: Please see the README on GitHub at @@ -16,6 +16,7 @@ test/testdata/*.hs library + buildable: True exposed-modules: Ide.Plugin.CallHierarchy other-modules: Ide.Plugin.CallHierarchy.Internal @@ -24,15 +25,15 @@ hs-source-dirs: src build-depends: - , aeson >=1.5.2.0 + , aeson , base >=4.12 && <5 , bytestring , containers , extra , ghc - , ghcide ^>= 1.6 || ^>= 1.7 + , ghcide ^>= 1.8 , hiedb - , hls-plugin-api ^>= 1.2 || ^>= 1.3 || ^>= 1.4 + , hls-plugin-api ^>= 1.5 , lens , lsp >=1.2.0.1 , sqlite-simple @@ -43,6 +44,7 @@ default-extensions: DataKinds test-suite tests + buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test @@ -55,7 +57,7 @@ , extra , filepath , hls-call-hierarchy-plugin - , hls-test-utils ^>=1.3 + , hls-test-utils ^>=1.4 , 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,8 +5,8 @@ import Ide.Types import Language.LSP.Types -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) +descriptor :: PluginDescriptor IdeState +descriptor = (defaultPluginDescriptor X.callHierarchyId) { 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -10,6 +11,7 @@ prepareCallHierarchy , incomingCalls , outgoingCalls +, callHierarchyId ) where import Control.Lens ((^.)) @@ -34,23 +36,23 @@ import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybe, pluginResponse, + throwPluginError) import Ide.Types import Language.LSP.Types 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 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 $ Right Nothing - | otherwise = pure $ Left $ responseError $ T.pack $ "Call Hierarchy: uriToNormalizedFilePath failed for: " <> show uri - where - uri = param ^. (L.textDocument . L.uri) - pos = param ^. L.position +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 @@ -189,16 +191,19 @@ deriving instance Ord SymbolKind deriving instance Ord SymbolTag deriving instance Ord CallHierarchyItem +#if !MIN_VERSION_aeson(1,5,2) +deriving instance Ord Value +#endif -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls -incomingCalls state pluginId param = do - liftIO $ runAction "CallHierarchy.incomingCalls" state $ +incomingCalls state pluginId param = pluginResponse $ do + calls <- 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" + mergeIncomingCalls + case calls of + Just x -> pure $ Just $ List x + Nothing -> throwPluginError "incomingCalls - Internal Error" where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall @@ -213,13 +218,13 @@ -- Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = do - liftIO $ runAction "CallHierarchy.outgoingCalls" state $ +outgoingCalls state pluginId param = pluginResponse $ do + calls <- 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" + mergeOutgoingCalls + case calls of + Just x -> pure $ Just $ List x + Nothing -> throwPluginError "outgoingCalls - Internal Error" where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -19,9 +19,10 @@ import System.FilePath import qualified System.IO.Extra import Test.Hls +import Test.Hls.Util (withCanonicalTempDir) plugin :: PluginDescriptor IdeState -plugin = descriptor "callHierarchy" +plugin = descriptor main :: IO () main = defaultTestRunner $ @@ -165,13 +166,13 @@ expected = mkCallHierarchyItemC "A" SkConstructor range selRange oneCaseWithCreate contents 1 13 expected , testGroup "type signature" - [ testCase "next line" $ do + [ knownBrokenForGhcVersions [GHC94] "type signature broken" $ 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 - , testCase "multi functions" $ do + , knownBrokenForGhcVersions [GHC94] "type signature broken" $ 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 @@ -197,6 +198,7 @@ testCase "xdata unavailable" $ runSessionWithServer plugin testDataDir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] + waitForKickDone [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= @@ -318,9 +320,10 @@ testGroup "Outgoing Calls" [ testGroup "single file" [ - testCase "xdata unavailable" $ withTempDir $ \dir -> + testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] + waitForKickDone [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= @@ -421,9 +424,10 @@ deriving instance Ord CallHierarchyOutgoingCall incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion -incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir -> +incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents + waitForKickDone items <- concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) <&> map (, range) @@ -443,9 +447,11 @@ 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) -> + waitForKickDone + items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do + p <- openDoc fp "haskell" + waitForKickDone + concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y) <&> map (, range) ) pr) mp @@ -460,9 +466,10 @@ closeDoc doc outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion -outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir -> +outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents + waitForKickDone items <- concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) <&> map (, range) @@ -481,9 +488,11 @@ 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) -> + waitForKickDone + items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do + p <- openDoc fp "haskell" + waitForKickDone + concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam p x y) <&> map (, range) ) pr) mp @@ -497,9 +506,10 @@ closeDoc doc oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion -oneCaseWithCreate contents queryX queryY expected = withTempDir $ \dir -> +oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents + waitForKickDone Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> liftIO $ item @?= expected (doc ^. L.uri) @@ -535,8 +545,3 @@ 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'