Enable pedantic for more components (#4061)

Author: jhrcek

.hlint.yaml

@@ -107,7 +107,6 @@
     - Ide.Plugin.Eval.Util
     - Ide.Plugin.Floskell
     - Ide.Plugin.ModuleName
-    - Ide.Plugin.Rename
     - Ide.Plugin.Class.ExactPrint
     - TExpectedActual
     - TRigidType

cabal.project

@@ -19,7 +19,7 @@ benchmarks: True
 write-ghc-environment-files: never
 
 -- Many of our tests only work single-threaded, and the only way to
--- ensure tasty runs everything purely single-threaded is to pass 
+-- ensure tasty runs everything purely single-threaded is to pass
 -- this at the top-level
 test-options: -j1
 
@@ -72,5 +72,3 @@ if impl(ghc >= 9.7)
   -- this is okay
   allow-newer:
     ekg-core:text,
-    -- https://github.com/haskell-primitive/primitive-unlifted/issues/39
-    primitive-unlifted:bytestring,

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -95,10 +95,10 @@ foiReferencesAtPoint file pos (FOIReferences asts) =
           adjustedLocs = HM.foldr go [] asts
           go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs
             where
-              refs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst)
-                   $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names
-              typerefs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation)
-                   $ concat $ mapMaybe (`M.lookup` tr) names
+              refs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst))
+                               (mapMaybe (\n -> M.lookup (Right n) rf) names)
+              typerefs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation))
+                                   (mapMaybe (`M.lookup` tr) names)
         in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts)
 
 getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name]

ghcide/test/exe/DiagnosticTests.hs

@@ -31,7 +31,7 @@ import           Language.LSP.Test
 import           System.Directory
 import           System.FilePath
 import           System.IO.Extra                 hiding (withTempDir)
--- import Test.QuickCheck.Instances ()
+
 import           Control.Lens                    ((^.))
 import           Control.Monad.Extra             (whenJust)
 import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))

ghcide/test/exe/TestUtils.hs

@@ -290,7 +290,7 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta
 
   assertOneDefinitionFound :: [Location] -> Session Location
   assertOneDefinitionFound [def] = pure def
-  assertOneDefinitionFound _ = liftIO $ assertFailure "Expecting exactly one definition"
+  assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)
 
   assertRangeCorrect Location{_range = foundRange} expectedRange =
     liftIO $ expectedRange @=? foundRange

haskell-language-server.cabal

@@ -105,7 +105,7 @@ flag isolateCabalfmtTests
   manual:      True
 
 library hls-cabal-fmt-plugin
-  import:           defaults, warnings
+  import:           defaults, pedantic, warnings
   exposed-modules:  Ide.Plugin.CabalFmt
   hs-source-dirs:   plugins/hls-cabal-fmt-plugin/src
   build-depends:
@@ -121,7 +121,7 @@ library hls-cabal-fmt-plugin
     , text
 
 test-suite hls-cabal-fmt-plugin-tests
-  import:             defaults, test-defaults, warnings
+  import:             defaults, pedantic, test-defaults, warnings
   type:               exitcode-stdio-1.0
   hs-source-dirs:     plugins/hls-cabal-fmt-plugin/test
   main-is:            Main.hs
@@ -150,7 +150,7 @@ common cabal
     cpp-options: -Dhls_cabal
 
 library hls-cabal-plugin
-  import:           defaults, warnings
+  import:           defaults, pedantic, warnings
   exposed-modules:
     Ide.Plugin.Cabal
     Ide.Plugin.Cabal.Diagnostics
@@ -193,7 +193,7 @@ library hls-cabal-plugin
   hs-source-dirs:   plugins/hls-cabal-plugin/src
 
 test-suite hls-cabal-plugin-tests
-  import:           defaults, test-defaults, warnings
+  import:           defaults, pedantic, test-defaults, warnings
   type:             exitcode-stdio-1.0
   hs-source-dirs:   plugins/hls-cabal-plugin/test
   main-is:          Main.hs
@@ -210,7 +210,6 @@ test-suite hls-cabal-plugin-tests
     , haskell-language-server:hls-cabal-plugin
     , hls-test-utils    == 2.6.0.0
     , lens
-    , lsp
     , lsp-types
     , text
     , text-rope
@@ -232,7 +231,7 @@ common class
     cpp-options: -Dhls_class
 
 library hls-class-plugin
-  import: defaults, warnings
+  import: defaults, pedantic, warnings
   exposed-modules:    Ide.Plugin.Class
   other-modules:      Ide.Plugin.Class.CodeAction
                     , Ide.Plugin.Class.CodeLens
@@ -262,14 +261,13 @@ library hls-class-plugin
     OverloadedStrings
 
 test-suite hls-class-plugin-tests
-  import: defaults, test-defaults, warnings
+  import: defaults, pedantic, test-defaults, warnings
   type:             exitcode-stdio-1.0
   hs-source-dirs:   plugins/hls-class-plugin/test
   main-is:          Main.hs
   build-depends:
     , base
     , filepath
-    , ghcide
     , haskell-language-server:hls-class-plugin
     , hls-test-utils     == 2.6.0.0
     , lens
@@ -292,7 +290,7 @@ common callHierarchy
     cpp-options: -Dhls_callHierarchy
 
 library hls-call-hierarchy-plugin
-  import: defaults, warnings
+  import: defaults, pedantic, warnings
   buildable: True
   exposed-modules:    Ide.Plugin.CallHierarchy
   other-modules:
@@ -317,7 +315,7 @@ library hls-call-hierarchy-plugin
   default-extensions: DataKinds
 
 test-suite hls-call-hierarchy-plugin-tests
-  import: defaults, test-defaults, warnings
+  import: defaults, pedantic, test-defaults, warnings
   type:             exitcode-stdio-1.0
   hs-source-dirs:   plugins/hls-call-hierarchy-plugin/test
   main-is:          Main.hs
@@ -350,7 +348,7 @@ common eval
     cpp-options: -Dhls_eval
 
 library hls-eval-plugin
-  import: defaults, warnings, pedantic
+  import: defaults, pedantic, warnings
   exposed-modules:
     Ide.Plugin.Eval
     Ide.Plugin.Eval.Types
@@ -396,7 +394,7 @@ library hls-eval-plugin
     DataKinds
 
 test-suite hls-eval-plugin-tests
-  import: defaults, test-defaults, warnings
+  import: defaults, pedantic, test-defaults, warnings
   type:             exitcode-stdio-1.0
   hs-source-dirs:   plugins/hls-eval-plugin/test
   main-is:          Main.hs
@@ -482,13 +480,12 @@ common rename
     cpp-options: -Dhls_rename
 
 library hls-rename-plugin
-  import:           defaults, warnings
+  import:           defaults, pedantic, warnings
   exposed-modules:  Ide.Plugin.Rename
   hs-source-dirs:   plugins/hls-rename-plugin/src
   build-depends:
     , base                  >=4.12    && <5
     , containers
-    , extra
     , ghcide                == 2.6.0.0
     , hashable
     , hiedb
@@ -507,7 +504,7 @@ library hls-rename-plugin
 
 
 test-suite hls-rename-plugin-tests
-  import:           defaults, test-defaults, warnings
+  import:           defaults, pedantic, test-defaults, warnings
   type:             exitcode-stdio-1.0
   hs-source-dirs:   plugins/hls-rename-plugin/test
   main-is:          Main.hs
@@ -593,7 +590,7 @@ common hlint
     cpp-options: -Dhls_hlint
 
 library hls-hlint-plugin
-  import: defaults, warnings, pedantic
+  import: defaults, pedantic, warnings, pedantic
   exposed-modules:    Ide.Plugin.Hlint
   hs-source-dirs:     plugins/hls-hlint-plugin/src
   build-depends:
@@ -627,7 +624,7 @@ library hls-hlint-plugin
     DataKinds
 
 test-suite hls-hlint-plugin-tests
-  import:           defaults, test-defaults, warnings
+  import:           defaults, pedantic, test-defaults, warnings
   type:             exitcode-stdio-1.0
   hs-source-dirs:   plugins/hls-hlint-plugin/test
   main-is:          Main.hs

hls-plugin-api/src/Ide/Plugin/Properties.hs

@@ -101,7 +101,7 @@ data SomePropertyKeyWithMetaData
     SomePropertyKeyWithMetaData (SPropertyKey k) (MetaData t)
 
 -- | 'Properties' is a partial implementation of json schema, without supporting union types and validation.
--- In hls, it defines a set of properties which used in dedicated configuration of a plugin.
+-- In hls, it defines a set of properties used in dedicated configuration of a plugin.
 -- A property is an immediate child of the json object in each plugin's "config" section.
 -- It was designed to be compatible with vscode's settings UI.
 -- Use 'emptyProperties' and 'useProperty' to create and consume 'Properties'.

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs

@@ -14,7 +14,6 @@ import qualified Data.Text.Utf16.Lines                         as Rope (Position
 import           Data.Text.Utf16.Rope.Mixed                    (Rope)
 import qualified Data.Text.Utf16.Rope.Mixed                    as Rope
 import           Development.IDE                               as D
-import qualified Development.IDE.Plugin.Completions.Logic      as Ghcide
 import qualified Development.IDE.Plugin.Completions.Types      as Ghcide
 import           Ide.Plugin.Cabal.Completion.Completer.Simple
 import           Ide.Plugin.Cabal.Completion.Completer.Snippet

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

@@ -165,10 +165,6 @@ mkSymbol = \case
 -------------- Incoming calls and outgoing calls ---------------------
 ----------------------------------------------------------------------
 
-#if !MIN_VERSION_aeson(1,5,2)
-deriving instance Ord Value
-#endif
-
 -- | Render incoming calls request.
 incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls
 incomingCalls state _pluginId param = do

plugins/hls-class-plugin/test/Main.hs

@@ -2,8 +2,6 @@
 {-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wall #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module Main
   ( main
@@ -13,10 +11,10 @@ import           Control.Exception             (catch)
 import           Control.Lens                  (Prism', prism', view, (^.),
                                                 (^..), (^?))
 import           Control.Monad                 (void)
+import           Data.Foldable                 (find)
 import           Data.Maybe
 import           Data.Row                      ((.==))
 import qualified Data.Text                     as T
-import           Development.IDE.Core.Compile  (sourceTypecheck)
 import qualified Ide.Plugin.Class              as Class
 import qualified Language.LSP.Protocol.Lens    as L
 import           Language.LSP.Protocol.Message
@@ -47,35 +45,35 @@ codeActionTests = testGroup
       , "Add placeholders for all missing methods"
       , "Add placeholders for all missing methods with signature(s)"
       ]
-  , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
-      executeCodeAction eqAction
-  , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do
-      executeCodeAction neAction
-  , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ \(_:_:_:_:allMethodsAction:_) -> do
-      executeCodeAction allMethodsAction
-  , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:_:_:fmapAction:_) -> do
-      executeCodeAction fmapAction
-  , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
-      executeCodeAction mmAction
-  , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:_:mmAction:_) -> do
-      executeCodeAction mmAction
-  , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
-      executeCodeAction _fAction
-  , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
-      executeCodeAction eqAction
-  , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
-      executeCodeAction gAction
-  , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ \(_:_:ghAction:_) -> do
-      executeCodeAction ghAction
+  , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $
+      getActionByTitle "Add placeholders for '=='"
+  , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $
+      getActionByTitle "Add placeholders for '/='"
+  , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $
+      getActionByTitle "Add placeholders for all missing methods"
+  , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $
+      getActionByTitle "Add placeholders for 'fmap'"
+  , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $
+      getActionByTitle "Add placeholders for 'f','g'"
+  , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $
+      getActionByTitle "Add placeholders for 'g','h'"
+  , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $
+      getActionByTitle "Add placeholders for '_f'"
+  , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $
+      getActionByTitle "Add placeholders for '=='"
+  , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $
+      getActionByTitle "Add placeholders for 'g'"
+  , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $
+      getActionByTitle "Add placeholders for 'g','h'"
   , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $
-      goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ \(_:eqWithSig:_) -> do
-        executeCodeAction eqWithSig
-  , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ \(_:eqWithSig:_) -> do
-      executeCodeAction eqWithSig
-  , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ \(_:eqWithSig:_) -> do
-      executeCodeAction eqWithSig
-  , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do
-      executeCodeAction multi
+      goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $
+        getActionByTitle "Add placeholders for '==' with signature(s)"
+  , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $
+      getActionByTitle "Add placeholders for '==' with signature(s)"
+  , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $
+      getActionByTitle "Add placeholders for '==' with signature(s)"
+  , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $
+      getActionByTitle "Add placeholders for 'pure','<*>' with signature(s)"
   , expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" []
   , expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired"
       [ "Add placeholders for 'f','g'"
@@ -162,14 +160,20 @@ goldenCodeLens title path idx =
         executeCommand $ fromJust $ (lens !! idx) ^. L.command
         void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)
 
-goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
-goldenWithClass title path desc act =
+goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session CodeAction) -> TestTree
+goldenWithClass title path desc findAction =
   goldenWithHaskellDoc def classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
     _ <- waitForDiagnosticsFrom doc
     actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
-    act actions
+    action <- findAction actions
+    executeCodeAction action
     void $ skipManyTill anyMessage (getDocumentEdit doc)
 
+getActionByTitle :: T.Text -> [CodeAction] -> Session CodeAction
+getActionByTitle title actions = case find (\a -> a ^. L.title == title) actions of
+    Just a -> pure a
+    Nothing -> liftIO $ assertFailure $ "Action " <> show title <> " not found in " <> show [a ^. L.title | a <- actions]
+
 expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree
 expectCodeActionsAvailable title path actionTitles =
   testCase title $ do