From 68280edcb135718075098ea03b4a99284999bac3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Thu, 18 Jan 2024 18:48:46 +0100 Subject: [PATCH] Fix -Wall and -Wunused-packages in pragmas plugin --- .../hls-pragmas-plugin.cabal | 8 ++-- .../src/Ide/Plugin/Pragmas.hs | 12 +++--- plugins/hls-pragmas-plugin/test/Main.hs | 40 ++++++++----------- 3 files changed, 28 insertions(+), 32 deletions(-) diff --git a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal index 27fae7cdb4..32617e2418 100644 --- a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal +++ b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal @@ -21,26 +21,28 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git +common warnings + ghc-options: -Wall -Wunused-packages + library + import: warnings exposed-modules: Ide.Plugin.Pragmas hs-source-dirs: src build-depends: , base >=4.12 && <5 , extra , fuzzy - , ghc , ghcide == 2.6.0.0 , hls-plugin-api == 2.6.0.0 , lens , lsp , text , transformers - , unordered-containers , containers - ghc-options: -Wall -Wno-name-shadowing default-language: Haskell2010 test-suite tests + import: warnings type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 5dba8482d9..511bc48525 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -22,9 +22,9 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) import Data.List.Extra (nubOrdOn) import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import qualified Data.Text as T -import Development.IDE +import Development.IDE hiding (line) import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) import Development.IDE.Core.PluginUtils @@ -85,7 +85,7 @@ mkCodeActionProvider mkSuggest state _plId parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents - pedits = (nubOrdOn snd . concat $ mkSuggest parsedModuleDynFlags <$> diags) + pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits @@ -146,7 +146,7 @@ suggestAddPragma mDynflags Diagnostic {_message, _source} disabled | Just dynFlags <- mDynflags = -- GHC does not export 'OnOff', so we have to view it as string - catMaybes $ T.stripPrefix "Off " . printOutputable <$> extensions dynFlags + mapMaybe (T.stripPrefix "Off " . printOutputable) (extensions dynFlags) | otherwise = -- When the module failed to parse, we don't have access to its -- dynFlags. In that case, simply don't disable any pragmas. @@ -201,7 +201,7 @@ completion _ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument position = complParams ^. L.position contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri - fmap (LSP.InL) $ case (contents, uriToFilePath' uri) of + fmap LSP.InL $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> result <$> VFS.getCompletionPrefix position cnts where @@ -252,7 +252,7 @@ completion _ide _ complParams = do | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" result Nothing = [] - _ -> return $ [] + _ -> return [] ----------------------------------------------------------------------- diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index 8eab91a91e..0b8e690dd9 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + module Main ( main ) where @@ -12,7 +12,6 @@ import Ide.Plugin.Pragmas import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls -import Test.Hls.Util (onlyWorkForGhcVersions) main :: IO () main = defaultTestRunner tests @@ -80,9 +79,6 @@ codeActionTests = , codeActionTestWithDisableWarning "before doc comments" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")] ] -ghc94regression :: String -ghc94regression = "to be reported" - codeActionTestWithPragmasSuggest :: String -> FilePath -> [(T.Text, String)] -> TestTree codeActionTestWithPragmasSuggest = codeActionTestWith pragmasSuggestPlugin @@ -105,8 +101,7 @@ codeActionTestWith descriptor testComment fp actions = codeActionTests' :: TestTree codeActionTests' = testGroup "additional code actions" - [ - goldenWithPragmas pragmasSuggestPlugin "no duplication" "NamedFieldPuns" $ \doc -> do + [ goldenWithPragmas pragmasSuggestPlugin "no duplication" "NamedFieldPuns" $ \doc -> do _ <- waitForDiagnosticsFrom doc cas <- map fromAction <$> getCodeActions doc (Range (Position 8 9) (Position 8 9)) ca <- liftIO $ case cas of @@ -124,18 +119,17 @@ codeActionTests' = completionTests :: TestTree completionTests = testGroup "completions" - [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] - , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] - , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] - , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing [0, 0, 0, 0, 0, 24] - , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing [0, 24, 0, 31, 0, 24] - , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24] - , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16] - , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23] - , onlyWorkForGhcVersions (>=GHC92) "GHC2021 flag introduced since ghc9.2" $ - completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16] + [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 34, 0, 4) + , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") (0, 4, 0, 31, 0, 4) + , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") (0, 4, 0, 32, 0, 4) + , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") (0, 4, 0, 33, 0, 4) + , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") (0, 4, 0, 34, 0, 4) + , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing (0, 0, 0, 0, 0, 24) + , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing (0, 24, 0, 31, 0, 24) + , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing (0, 4, 0, 34, 0, 24) + , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16) + , completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing (0, 13, 0, 31, 0, 23) + , completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16) ] completionSnippetTests :: TestTree @@ -151,7 +145,7 @@ completionSnippetTests = in completionTest (T.unpack label) "Completion.hs" input label (Just InsertTextFormat_Snippet) (Just $ "{-# " <> insertText <> " #-}") (Just detail) - [0, 0, 0, 34, 0, fromIntegral $ T.length input]) + (0, 0, 0, 34, 0, fromIntegral $ T.length input)) dontSuggestCompletionTests :: TestTree dontSuggestCompletionTests = @@ -162,7 +156,7 @@ dontSuggestCompletionTests = , provideNoCompletionsTest "when no word has been typed" "Completion.hs" Nothing (Position 3 0) , provideNoCompletionsTest "when expecting auto complete on modules" "Completion.hs" (Just $ mkEdit (8,6) (8,8) "Data.Maybe.WA") (Position 8 19) ] - individualPragmaTests = validPragmas <&> \(insertText,label,detail,appearWhere) -> + individualPragmaTests = validPragmas <&> \(_insertText,label,_detail,appearWhere) -> let completionPrompt = T.toLower $ T.init label promptLen = fromIntegral (T.length completionPrompt) in case appearWhere of @@ -176,8 +170,8 @@ mkEdit :: (UInt,UInt) -> (UInt,UInt) -> T.Text -> TextEdit mkEdit (startLine, startCol) (endLine, endCol) newText = TextEdit (Range (Position startLine startCol) (Position endLine endCol)) newText -completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree -completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail [delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol] = +completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> (UInt, UInt, UInt, UInt, UInt, UInt) -> TestTree +completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail (delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol) = testCase testComment $ runSessionWithServer def pragmasCompletionPlugin testDataDir $ do doc <- openDoc fileName "haskell" _ <- waitForDiagnostics