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 61ad715478..151e5f020a 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -19,7 +19,11 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git +common warnings + ghc-options: -Wall -Wunused-packages + library + import: warnings buildable: True exposed-modules: Ide.Plugin.CallHierarchy other-modules: @@ -40,12 +44,12 @@ library , lsp >=2.3 , sqlite-simple , text - , unordered-containers default-language: Haskell2010 default-extensions: DataKinds test-suite tests + import: warnings type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test 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 dcae70b249..9f34dbe27c 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 @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -13,43 +14,45 @@ module Ide.Plugin.CallHierarchy.Internal ( , outgoingCalls ) where -import Control.Lens ((^.)) +import Control.Lens (Lens', (^.)) import Control.Monad.IO.Class -import Data.Aeson as A -import Data.List (groupBy, sortBy) -import qualified Data.Map as M +import Data.Aeson as A +import Data.Functor ((<&>)) +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 Data.Ord (comparing) +import qualified Data.Set as S +import qualified Data.Text as T import Data.Tuple.Extra import Development.IDE -import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat as Compat +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 HieDb (Symbol (Symbol)) +import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types import Ide.Plugin.Error import Ide.Types -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Text.Read (readMaybe) +import Prelude hiding (mod, span) +import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy prepareCallHierarchy state _ param = do - nfp <- getNormalizedFilePathE (param ^. L.textDocument ^. L.uri) + nfp <- getNormalizedFilePathE (param ^. (L.textDocument . L.uri)) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state $ prepareCallHierarchyItem nfp (param ^. L.position) pure $ InL items prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem] -prepareCallHierarchyItem nfp pos = use GetHieAst nfp >>= \case - Nothing -> pure mempty - Just (HAR _ hf _ _ _) -> pure $ prepareByAst hf pos nfp +prepareCallHierarchyItem nfp pos = use GetHieAst nfp <&> \case + Nothing -> mempty + Just (HAR _ hf _ _ _) -> prepareByAst hf pos nfp prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem] prepareByAst hf pos nfp = @@ -173,7 +176,7 @@ deriving instance Ord Value -- | Render incoming calls request. incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls -incomingCalls state pluginId param = do +incomingCalls state _pluginId param = do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state $ queryCalls @@ -181,14 +184,14 @@ incomingCalls state pluginId param = do Q.incomingCalls mkCallHierarchyIncomingCall (mergeCalls CallHierarchyIncomingCall L.from) - pure $ InL $ calls + pure $ InL calls where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall -- | Render outgoing calls request. outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls -outgoingCalls state pluginId param = do +outgoingCalls state _pluginId param = do calls <- liftIO $ runAction "CallHierarchy.outgoingCalls" state $ queryCalls @@ -196,15 +199,22 @@ outgoingCalls state pluginId param = do Q.outgoingCalls mkCallHierarchyOutgoingCall (mergeCalls CallHierarchyOutgoingCall L.to) - pure $ InL $ calls + pure $ InL calls where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall + -- | Merge calls from the same place +mergeCalls :: + L.HasFromRanges s [Range] + => (CallHierarchyItem -> [Range] -> s) + -> Lens' s CallHierarchyItem + -> [s] + -> [s] mergeCalls constructor target = concatMap merge . groupBy (\a b -> a ^. target == b ^. target) - . sortBy (\a b -> (a ^. target) `compare` (b ^. target)) + . sortBy (comparing (^. target)) where merge [] = [] merge calls@(call:_) = @@ -235,7 +245,7 @@ mkCallHierarchyCall mk v@Vertex{..} = do case items of [item] -> pure $ Just $ mk item [range] _ -> pure Nothing - _ -> pure Nothing + [] -> pure Nothing -- | Unified queries include incoming calls and outgoing calls. queryCalls :: (Show a) @@ -257,7 +267,6 @@ queryCalls item queryFunc makeFunc merge | otherwise = pure mempty where uri = item ^. L.uri - xdata = item ^. L.data_ pos = item ^. (L.selectionRange . L.start) getSymbol nfp = case item ^. L.data_ of @@ -267,9 +276,9 @@ queryCalls item queryFunc makeFunc merge 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 + getSymbolFromAst nfp pos_ = use GetHieAst nfp <&> \case + Nothing -> 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 + case listToMaybe $ pointCommand hf pos_ extract of + Just infos -> mkSymbol . fst3 =<< listToMaybe infos + Nothing -> Nothing 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 1eee277caf..30f85219bf 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 @@ -13,6 +13,7 @@ import Database.SQLite.Simple import Development.IDE.GHC.Compat import HieDb (HieDb (getConn), Symbol (..)) import Ide.Plugin.CallHierarchy.Types +import Prelude hiding (mod) incomingCalls :: HieDb -> Symbol -> IO [Vertex] incomingCalls (getConn -> conn) symbol = do diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index af51fdd04c..4e4db53087 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} module Main (main) where @@ -17,11 +16,8 @@ import Development.IDE.Test import Ide.Plugin.CallHierarchy import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Test as Test -import System.Directory.Extra import System.FilePath -import qualified System.IO.Extra import Test.Hls -import Test.Hls.Util (withCanonicalTempDir) plugin :: PluginTestDescriptor () plugin = mkPluginTestDescriptor' descriptor "call-hierarchy" @@ -196,20 +192,16 @@ incomingCallsTests :: TestTree incomingCallsTests = testGroup "Incoming Calls" [ testGroup "single file" - [ - testCase "xdata unavailable" $ + [ testCase "xdata unavailable" $ runSessionWithServer def plugin testDataDir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (testDataDir "A.hs") - [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item [mkRange 1 2 1 3]] - Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= - \case - [item] -> do - let itemNoData = set L.data_ Nothing item - Test.incomingCalls (mkIncomingCallsParam itemNoData) >>= - \res -> liftIO $ sort expected @=? sort res - _ -> liftIO $ assertFailure "Not exactly one element" + item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) + let itemNoData = set L.data_ Nothing item' + res <- Test.incomingCalls (mkIncomingCallsParam itemNoData) + liftIO $ sort expected @=? sort res closeDoc doc , testCase "xdata available" $ do let contents = T.unlines ["a=3","b=a"] @@ -321,20 +313,16 @@ outgoingCallsTests :: TestTree outgoingCallsTests = testGroup "Outgoing Calls" [ testGroup "single file" - [ - testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> + [ testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> runSessionWithServer def plugin dir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (dir "A.hs") - [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) let expected = [CallHierarchyOutgoingCall item [mkRange 1 2 1 3]] - Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= - \case - [item] -> do - let itemNoData = set L.data_ Nothing item - Test.outgoingCalls (mkOutgoingCallsParam itemNoData) >>= - \res -> liftIO $ sort expected @=? sort res - _ -> liftIO $ assertFailure "Not exactly one element" + item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) + let itemNoData = set L.data_ Nothing item' + res <- Test.outgoingCalls (mkOutgoingCallsParam itemNoData) + liftIO $ sort expected @=? sort res closeDoc doc , testCase "xdata available" $ do let contents = T.unlines ["a=3", "b=a"] @@ -434,13 +422,9 @@ incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTemp ) (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" + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.incomingCalls (mkIncomingCallsParam item) + liftIO $ sort expected @=? sort res closeDoc doc incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion @@ -456,13 +440,9 @@ incomingCallMultiFileTestCase filepath queryX queryY mp = <&> 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" + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.incomingCalls (mkIncomingCallsParam item) + liftIO $ sort expected @=? sort res closeDoc doc outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion @@ -476,12 +456,9 @@ outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTemp ) (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" + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.outgoingCalls (mkOutgoingCallsParam item) + liftIO $ sort expected @=? sort res closeDoc doc outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion @@ -497,12 +474,9 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp = <&> 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" + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + res <- Test.outgoingCalls (mkOutgoingCallsParam item) + liftIO $ sort expected @=? sort res closeDoc doc oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion @@ -510,12 +484,15 @@ oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir runSessionWithServer def plugin dir $ do doc <- createDoc "A.hs" "haskell" contents waitForIndex (dir "A.hs") - Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= - \case - [item] -> liftIO $ expected (doc ^. L.uri) item - res -> liftIO $ assertFailure "Not one element" + item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) + liftIO $ expected (doc ^. L.uri) item closeDoc doc +expectOneElement :: [a] -> Session a +expectOneElement = \case + [x] -> pure x + xs -> liftIO . assertFailure $ "Expecting exactly one element, but got " ++ show (length xs) + mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do assertHierarchyItem name name' @@ -528,7 +505,7 @@ mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem na case xdata' of Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata) Just v -> case Aeson.fromJSON v of - Aeson.Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v) + Aeson.Success v' -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v') Aeson.Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err) where tags = Nothing @@ -570,6 +547,6 @@ waitForIndex fp1 = skipManyTill anyMessage $ void $ referenceReady lenientEquals -- filepath from the message lenientEquals :: FilePath -> Bool lenientEquals fp2 - | isRelative fp1 = any (equalFilePath fp1) (map (foldr () "") $ tails $ splitDirectories fp2) + | isRelative fp1 = any (equalFilePath fp1 . joinPath) $ tails $ splitDirectories fp2 | otherwise = equalFilePath fp1 fp2