Fix -Wall, -Wunused-packages and hlint warnings in call-hierarchy plugin

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

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,38 +176,45 @@ 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
             (param ^. L.item)
             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
             (param ^. L.item)
             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

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

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,25 +474,25 @@ 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
 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