Skip to content

Commit 665854f

Browse files
jhrcekjhrcek
authored
Fix -Wall, -Wunused-packages and hlint warnings in call-hierarchy plugin (#3979)
* Fix -Wall and -Wunused-packages in call-hierarchy plugin * Make tests more uniform
1 parent 1da09d2 commit 665854f

File tree

4 files changed

+80
-89
lines changed

4 files changed

+80
-89
lines changed

‎plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,11 @@ source-repository head
1919
type: git
2020
location: https://github.com/haskell/haskell-language-server.git
2121

22+
common warnings
23+
ghc-options: -Wall -Wunused-packages
24+
2225
library
26+
import: warnings
2327
buildable: True
2428
exposed-modules: Ide.Plugin.CallHierarchy
2529
other-modules:
@@ -40,12 +44,12 @@ library
4044
, lsp >=2.3
4145
, sqlite-simple
4246
, text
43-
, unordered-containers
4447

4548
default-language: Haskell2010
4649
default-extensions: DataKinds
4750

4851
test-suite tests
52+
import: warnings
4953
type: exitcode-stdio-1.0
5054
default-language: Haskell2010
5155
hs-source-dirs: test

‎plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs‎

Lines changed: 37 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
{-# LANGUAGE LambdaCase #-}
44
{-# LANGUAGE NamedFieldPuns #-}
55
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE Rank2Types #-}
67
{-# LANGUAGE RecordWildCards #-}
78
{-# LANGUAGE ScopedTypeVariables #-}
89
{-# LANGUAGE StandaloneDeriving #-}
@@ -13,43 +14,45 @@ module Ide.Plugin.CallHierarchy.Internal (
1314
, outgoingCalls
1415
) where
1516

16-
import Control.Lens ((^.))
17+
import Control.Lens (Lens', (^.))
1718
import Control.Monad.IO.Class
18-
import Data.Aeson as A
19-
import Data.List (groupBy, sortBy)
20-
import qualified Data.Map as M
19+
import Data.Aeson as A
20+
import Data.Functor ((<&>))
21+
import Data.List (groupBy, sortBy)
22+
import qualified Data.Map as M
2123
import Data.Maybe
22-
import qualified Data.Set as S
23-
import qualified Data.Text as T
24+
import Data.Ord (comparing)
25+
import qualified Data.Set as S
26+
import qualified Data.Text as T
2427
import Data.Tuple.Extra
2528
import Development.IDE
26-
import qualified Development.IDE.Core.PluginUtils as PluginUtils
2729
import Development.IDE.Core.Shake
28-
import Development.IDE.GHC.Compat as Compat
30+
import Development.IDE.GHC.Compat as Compat
2931
import Development.IDE.Spans.AtPoint
30-
import HieDb (Symbol (Symbol))
31-
import qualified Ide.Plugin.CallHierarchy.Query as Q
32+
import HieDb (Symbol (Symbol))
33+
import qualified Ide.Plugin.CallHierarchy.Query as Q
3234
import Ide.Plugin.CallHierarchy.Types
3335
import Ide.Plugin.Error
3436
import Ide.Types
35-
import qualified Language.LSP.Protocol.Lens as L
37+
import qualified Language.LSP.Protocol.Lens as L
3638
import Language.LSP.Protocol.Message
3739
import Language.LSP.Protocol.Types
38-
import Text.Read (readMaybe)
40+
import Prelude hiding (mod, span)
41+
import Text.Read (readMaybe)
3942

4043
-- | Render prepare call hierarchy request.
4144
prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy
4245
prepareCallHierarchy state _ param = do
43-
nfp <- getNormalizedFilePathE (param ^. L.textDocument ^. L.uri)
46+
nfp <- getNormalizedFilePathE (param ^. (L.textDocument . L.uri))
4447
items <- liftIO
4548
$ runAction "CallHierarchy.prepareHierarchy" state
4649
$ prepareCallHierarchyItem nfp (param ^. L.position)
4750
pure $ InL items
4851

4952
prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem]
50-
prepareCallHierarchyItem nfp pos = use GetHieAst nfp >>= \case
51-
Nothing -> pure mempty
52-
Just (HAR _ hf _ _ _) -> pure $ prepareByAst hf pos nfp
53+
prepareCallHierarchyItem nfp pos = use GetHieAst nfp <&> \case
54+
Nothing -> mempty
55+
Just (HAR _ hf _ _ _) -> prepareByAst hf pos nfp
5356

5457
prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem]
5558
prepareByAst hf pos nfp =
@@ -173,38 +176,45 @@ deriving instance Ord Value
173176

174177
-- | Render incoming calls request.
175178
incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls
176-
incomingCalls state pluginId param = do
179+
incomingCalls state _pluginId param = do
177180
calls <- liftIO
178181
$ runAction "CallHierarchy.incomingCalls" state
179182
$ queryCalls
180183
(param ^. L.item)
181184
Q.incomingCalls
182185
mkCallHierarchyIncomingCall
183186
(mergeCalls CallHierarchyIncomingCall L.from)
184-
pure $ InL $ calls
187+
pure $ InL calls
185188
where
186189
mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall)
187190
mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall
188191

189192
-- | Render outgoing calls request.
190193
outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls
191-
outgoingCalls state pluginId param = do
194+
outgoingCalls state _pluginId param = do
192195
calls <- liftIO
193196
$ runAction "CallHierarchy.outgoingCalls" state
194197
$ queryCalls
195198
(param ^. L.item)
196199
Q.outgoingCalls
197200
mkCallHierarchyOutgoingCall
198201
(mergeCalls CallHierarchyOutgoingCall L.to)
199-
pure $ InL $ calls
202+
pure $ InL calls
200203
where
201204
mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall)
202205
mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall
206+
203207
-- | Merge calls from the same place
208+
mergeCalls ::
209+
L.HasFromRanges s [Range]
210+
=> (CallHierarchyItem -> [Range] -> s)
211+
-> Lens' s CallHierarchyItem
212+
-> [s]
213+
-> [s]
204214
mergeCalls constructor target =
205215
concatMap merge
206216
. groupBy (\a b -> a ^. target == b ^. target)
207-
. sortBy (\a b -> (a ^. target) `compare` (b ^. target))
217+
. sortBy (comparing (^. target))
208218
where
209219
merge [] = []
210220
merge calls@(call:_) =
@@ -235,7 +245,7 @@ mkCallHierarchyCall mk v@Vertex{..} = do
235245
case items of
236246
[item] -> pure $ Just $ mk item [range]
237247
_ -> pure Nothing
238-
_ -> pure Nothing
248+
[] -> pure Nothing
239249

240250
-- | Unified queries include incoming calls and outgoing calls.
241251
queryCalls :: (Show a)
@@ -257,7 +267,6 @@ queryCalls item queryFunc makeFunc merge
257267
| otherwise = pure mempty
258268
where
259269
uri = item ^. L.uri
260-
xdata = item ^. L.data_
261270
pos = item ^. (L.selectionRange . L.start)
262271

263272
getSymbol nfp = case item ^. L.data_ of
@@ -267,9 +276,9 @@ queryCalls item queryFunc makeFunc merge
267276
Nothing -> getSymbolFromAst nfp pos -- Fallback if xdata lost, some editor(VSCode) will drop it
268277

269278
getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol)
270-
getSymbolFromAst nfp pos = use GetHieAst nfp >>= \case
271-
Nothing -> pure Nothing
279+
getSymbolFromAst nfp pos_ = use GetHieAst nfp <&> \case
280+
Nothing -> Nothing
272281
Just (HAR _ hf _ _ _) -> do
273-
case listToMaybe $ pointCommand hf pos extract of
274-
Just infos -> maybe (pure Nothing) pure $ mkSymbol . fst3 <$> listToMaybe infos
275-
Nothing -> pure Nothing
282+
case listToMaybe $ pointCommand hf pos_ extract of
283+
Just infos -> mkSymbol . fst3 =<< listToMaybe infos
284+
Nothing -> Nothing

‎plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import Database.SQLite.Simple
1313
import Development.IDE.GHC.Compat
1414
import HieDb (HieDb (getConn), Symbol (..))
1515
import Ide.Plugin.CallHierarchy.Types
16+
import Prelude hiding (mod)
1617

1718
incomingCalls :: HieDb -> Symbol -> IO [Vertex]
1819
incomingCalls (getConn -> conn) symbol = do

‎plugins/hls-call-hierarchy-plugin/test/Main.hs‎

Lines changed: 37 additions & 60 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,7 @@
1-
{-# LANGUAGE LambdaCase #-}
2-
{-# LANGUAGE OverloadedStrings #-}
3-
{-# LANGUAGE RankNTypes #-}
4-
{-# LANGUAGE StandaloneDeriving #-}
5-
{-# LANGUAGE TupleSections #-}
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RankNTypes #-}
4+
{-# LANGUAGE TupleSections #-}
65

76
module Main (main) where
87

@@ -17,11 +16,8 @@ import Development.IDE.Test
1716
import Ide.Plugin.CallHierarchy
1817
import qualified Language.LSP.Protocol.Lens as L
1918
import qualified Language.LSP.Test as Test
20-
import System.Directory.Extra
2119
import System.FilePath
22-
import qualified System.IO.Extra
2320
import Test.Hls
24-
import Test.Hls.Util (withCanonicalTempDir)
2521

2622
plugin :: PluginTestDescriptor ()
2723
plugin = mkPluginTestDescriptor' descriptor "call-hierarchy"
@@ -196,20 +192,16 @@ incomingCallsTests :: TestTree
196192
incomingCallsTests =
197193
testGroup "Incoming Calls"
198194
[ testGroup "single file"
199-
[
200-
testCase "xdata unavailable" $
195+
[ testCase "xdata unavailable" $
201196
runSessionWithServer def plugin testDataDir $ do
202197
doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
203198
waitForIndex (testDataDir </> "A.hs")
204-
[item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)
199+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)
205200
let expected = [CallHierarchyIncomingCall item [mkRange 1 2 1 3]]
206-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>=
207-
\case
208-
[item] -> do
209-
let itemNoData = set L.data_ Nothing item
210-
Test.incomingCalls (mkIncomingCallsParam itemNoData) >>=
211-
\res -> liftIO $ sort expected @=? sort res
212-
_ -> liftIO $ assertFailure "Not exactly one element"
201+
item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0)
202+
let itemNoData = set L.data_ Nothing item'
203+
res <- Test.incomingCalls (mkIncomingCallsParam itemNoData)
204+
liftIO $ sort expected @=? sort res
213205
closeDoc doc
214206
, testCase "xdata available" $ do
215207
let contents = T.unlines ["a=3","b=a"]
@@ -321,20 +313,16 @@ outgoingCallsTests :: TestTree
321313
outgoingCallsTests =
322314
testGroup "Outgoing Calls"
323315
[ testGroup "single file"
324-
[
325-
testCase "xdata unavailable" $ withCanonicalTempDir $ \dir ->
316+
[ testCase "xdata unavailable" $ withCanonicalTempDir $ \dir ->
326317
runSessionWithServer def plugin dir $ do
327318
doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
328319
waitForIndex (dir </> "A.hs")
329-
[item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1)
320+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1)
330321
let expected = [CallHierarchyOutgoingCall item [mkRange 1 2 1 3]]
331-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>=
332-
\case
333-
[item] -> do
334-
let itemNoData = set L.data_ Nothing item
335-
Test.outgoingCalls (mkOutgoingCallsParam itemNoData) >>=
336-
\res -> liftIO $ sort expected @=? sort res
337-
_ -> liftIO $ assertFailure "Not exactly one element"
322+
item' <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)
323+
let itemNoData = set L.data_ Nothing item'
324+
res <- Test.outgoingCalls (mkOutgoingCallsParam itemNoData)
325+
liftIO $ sort expected @=? sort res
338326
closeDoc doc
339327
, testCase "xdata available" $ do
340328
let contents = T.unlines ["a=3", "b=a"]
@@ -434,13 +422,9 @@ incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTemp
434422
)
435423
(zip positions ranges)
436424
let expected = map mkCallHierarchyIncomingCall items
437-
-- liftIO delay
438-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
439-
\case
440-
[item] -> do
441-
Test.incomingCalls (mkIncomingCallsParam item) >>=
442-
\res -> liftIO $ sort expected @=? sort res
443-
_ -> liftIO $ assertFailure "Not one element"
425+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)
426+
res <- Test.incomingCalls (mkIncomingCallsParam item)
427+
liftIO $ sort expected @=? sort res
444428
closeDoc doc
445429

446430
incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion
@@ -456,13 +440,9 @@ incomingCallMultiFileTestCase filepath queryX queryY mp =
456440
<&> map (, range)
457441
) pr) mp
458442
let expected = map mkCallHierarchyIncomingCall items
459-
-- liftIO delay
460-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
461-
\case
462-
[item] -> do
463-
Test.incomingCalls (mkIncomingCallsParam item) >>=
464-
\res -> liftIO $ sort expected @=? sort res
465-
_ -> liftIO $ assertFailure "Not one element"
443+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)
444+
res <- Test.incomingCalls (mkIncomingCallsParam item)
445+
liftIO $ sort expected @=? sort res
466446
closeDoc doc
467447

468448
outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion
@@ -476,12 +456,9 @@ outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTemp
476456
)
477457
(zip positions ranges)
478458
let expected = map mkCallHierarchyOutgoingCall items
479-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
480-
\case
481-
[item] -> do
482-
Test.outgoingCalls (mkOutgoingCallsParam item) >>=
483-
\res -> liftIO $ sort expected @=? sort res
484-
_ -> liftIO $ assertFailure "Not one element"
459+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)
460+
res <- Test.outgoingCalls (mkOutgoingCallsParam item)
461+
liftIO $ sort expected @=? sort res
485462
closeDoc doc
486463

487464
outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int, Int), Range)] -> Assertion
@@ -497,25 +474,25 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp =
497474
<&> map (, range)
498475
) pr) mp
499476
let expected = map mkCallHierarchyOutgoingCall items
500-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
501-
\case
502-
[item] -> do
503-
Test.outgoingCalls (mkOutgoingCallsParam item) >>=
504-
\res -> liftIO $ sort expected @=? sort res
505-
_ -> liftIO $ assertFailure "Not one element"
477+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)
478+
res <- Test.outgoingCalls (mkOutgoingCallsParam item)
479+
liftIO $ sort expected @=? sort res
506480
closeDoc doc
507481

508482
oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion
509483
oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir ->
510484
runSessionWithServer def plugin dir $ do
511485
doc <- createDoc "A.hs" "haskell" contents
512486
waitForIndex (dir </> "A.hs")
513-
Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
514-
\case
515-
[item] -> liftIO $ expected (doc ^. L.uri) item
516-
res -> liftIO $ assertFailure "Not one element"
487+
item <- expectOneElement =<< Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY)
488+
liftIO $ expected (doc ^. L.uri) item
517489
closeDoc doc
518490

491+
expectOneElement :: [a] -> Session a
492+
expectOneElement = \case
493+
[x] -> pure x
494+
xs -> liftIO . assertFailure $ "Expecting exactly one element, but got " ++ show (length xs)
495+
519496
mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion
520497
mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do
521498
assertHierarchyItem name name'
@@ -528,7 +505,7 @@ mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem na
528505
case xdata' of
529506
Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata)
530507
Just v -> case Aeson.fromJSON v of
531-
Aeson.Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v)
508+
Aeson.Success v' -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v')
532509
Aeson.Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err)
533510
where
534511
tags = Nothing
@@ -570,6 +547,6 @@ waitForIndex fp1 = skipManyTill anyMessage $ void $ referenceReady lenientEquals
570547
-- filepath from the message
571548
lenientEquals :: FilePath -> Bool
572549
lenientEquals fp2
573-
| isRelative fp1 = any (equalFilePath fp1) (map (foldr (</>) "") $ tails $ splitDirectories fp2)
550+
| isRelative fp1 = any (equalFilePath fp1 . joinPath) $ tails $ splitDirectories fp2
574551
| otherwise = equalFilePath fp1 fp2
575552

0 commit comments

Comments
 (0)