From 911d10f5b12b0737ff4a521061a5082facb1ae89 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 03:09:51 -0500 Subject: [PATCH 1/7] fix #2612. apply fixities to parsed source before sent to apply-refact --- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 4 +- plugins/hls-hlint-plugin/test/Main.hs | 37 ++++++++++++++++--- .../testdata/RightToLeftFixities.expected.hs | 6 +++ .../test/testdata/RightToLeftFixities.hs | 6 +++ 4 files changed, 46 insertions(+), 7 deletions(-) create mode 100644 plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs create mode 100644 plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index c4da71d5cc..feee93ac9b 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -52,6 +52,7 @@ import Development.IDE.Core.Rules (defineNoFil usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) import Refact.Apply +import qualified Refact.Fixity as Refact #ifdef HLINT_ON_GHC_LIB import Data.List (nub) @@ -555,7 +556,8 @@ applyHint ide nfp mhint = -- apply-refact uses RigidLayout let rigidLayout = deltaOptions RigidLayout (anns', modu') <- - ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout + ExceptT $ mapM (uncurry Refact.applyFixities) + $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) `catches` errorHandlers #endif diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 86bbfad319..7707733932 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -8,6 +8,7 @@ module Main import Control.Lens ((^.)) import Data.Aeson (Value (..), object, toJSON, (.=)) +import Data.Functor (void) import Data.List (find) import qualified Data.Map as Map import Data.Maybe (fromJust, isJust) @@ -30,26 +31,40 @@ tests = testGroup "hlint" [ suggestionsTests , configTests , ignoreHintTests + , applyHintTests ] getIgnoreHintText :: T.Text -> T.Text getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module" +getApplyHintText :: T.Text -> T.Text +getApplyHintText name = "Apply hint \"Avoid reverse\"" -- "Apply hint \"" <> name <> "\"" + ignoreHintTests :: TestTree ignoreHintTests = testGroup "hlint ignore hint tests" [ - ignoreGoldenTest + ignoreHintGoldenTest "Ignore hint in this module inserts -Wno-unrecognised-pragmas and hlint ignore pragma if warn unrecognized pragmas is off" "UnrecognizedPragmasOff" (Point 3 8) "Eta reduce" - , ignoreGoldenTest + , ignoreHintGoldenTest "Ignore hint in this module inserts only hlint ignore pragma if warn unrecognized pragmas is on" "UnrecognizedPragmasOn" (Point 3 9) "Eta reduce" ] +applyHintTests :: TestTree +applyHintTests = testGroup "hlint apply hint tests" + [ + applyHintGoldenTest + "[#2612] Apply hint works when operator fixities go right-to-left" + "RightToLeftFixities" + (Point 6 13) + "Avoid reverse" + ] + suggestionsTests :: TestTree suggestionsTests = testGroup "hlint suggestions" [ @@ -378,13 +393,23 @@ makeCodeActionFoundAtString :: Point -> String makeCodeActionFoundAtString Point {..} = "CodeAction found at line: " <> show line <> ", column: " <> show column -ignoreGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree -ignoreGoldenTest testCaseName goldenFilename point hintName = +ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +ignoreHintGoldenTest testCaseName goldenFilename point hintName = + goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) + +applyHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +applyHintGoldenTest testCaseName goldenFilename point hintName = + goldenTest testCaseName goldenFilename point (getApplyHintText hintName) + +goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree +goldenTest testCaseName goldenFilename point hintText = setupGoldenHlintTest testCaseName goldenFilename $ \document -> do waitForDiagnosticsFromSource document "hlint" actions <- getCodeActions document $ pointToRange point - case find ((== Just (getIgnoreHintText hintName)) . getCodeActionTitle) actions of - Just (InR codeAction) -> executeCodeAction codeAction + case find ((== Just hintText) . getCodeActionTitle) actions of + Just (InR codeAction) -> do + executeCodeAction codeAction + void $ skipManyTill anyMessage $ getDocumentEdit document _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree diff --git a/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs new file mode 100644 index 0000000000..32483bef6f --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.expected.hs @@ -0,0 +1,6 @@ +module RightToLeftFixities where +import Data.List (sortOn) +import Control.Arrow ((&&&)) +import Data.Ord (Down(Down)) +functionB :: [String] -> [(Char,Int)] +functionB = sortOn (Down . snd) . map (head &&& length) . id diff --git a/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs new file mode 100644 index 0000000000..a9b5d141b3 --- /dev/null +++ b/plugins/hls-hlint-plugin/test/testdata/RightToLeftFixities.hs @@ -0,0 +1,6 @@ +module RightToLeftFixities where +import Data.List (sortOn) +import Control.Arrow ((&&&)) +import Data.Ord (Down(Down)) +functionB :: [String] -> [(Char,Int)] +functionB = reverse . sortOn snd . map (head &&& length) . id From f623b8231cdedac327e237cc7be57e85e3d2f751 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 05:36:10 -0500 Subject: [PATCH 2/7] fix tests --- plugins/hls-hlint-plugin/test/Main.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 7707733932..bda0099c62 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -7,6 +7,7 @@ module Main ) where import Control.Lens ((^.)) +import Control.Monad (when) import Data.Aeson (Value (..), object, toJSON, (.=)) import Data.Functor (void) import Data.List (find) @@ -398,7 +399,7 @@ ignoreHintGoldenTest testCaseName goldenFilename point hintName = goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) applyHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree -applyHintGoldenTest testCaseName goldenFilename point hintName = +applyHintGoldenTest testCaseName goldenFilename point hintName = do goldenTest testCaseName goldenFilename point (getApplyHintText hintName) goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree @@ -409,7 +410,8 @@ goldenTest testCaseName goldenFilename point hintText = case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> do executeCodeAction codeAction - void $ skipManyTill anyMessage $ getDocumentEdit document + when (isJust (codeAction ^. L.command)) $ + void $ skipManyTill anyMessage $ getDocumentEdit document _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree From db9ecda0a92462051746c45792194b274bd7864a Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 13:25:46 -0500 Subject: [PATCH 3/7] dont hardcode getApplyHintText --- plugins/hls-hlint-plugin/test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index bda0099c62..69d92a28dc 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -39,7 +39,7 @@ getIgnoreHintText :: T.Text -> T.Text getIgnoreHintText name = "Ignore hint \"" <> name <> "\" in this module" getApplyHintText :: T.Text -> T.Text -getApplyHintText name = "Apply hint \"Avoid reverse\"" -- "Apply hint \"" <> name <> "\"" +getApplyHintText name = "Apply hint \"" <> name <> "\"" ignoreHintTests :: TestTree ignoreHintTests = testGroup "hlint ignore hint tests" From 753056014bf4c864b6f9ca47d47edcbb9b6114fe Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 15:05:29 -0500 Subject: [PATCH 4/7] try and fix pedantic warning --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index fa1f5f1e04..74794cd939 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -51,17 +51,17 @@ import Development.IDE.Core.Rules (defineNoFil getParsedModuleWithComments, usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) -import Refact.Apply +import qualified Refact.Apply as Refact import qualified Refact.Fixity as Refact #ifdef HLINT_ON_GHC_LIB import Data.List (nub) import Development.IDE.GHC.Compat (BufSpan, DynFlags, + WarningFlag (Opt_WarnUnrecognisedPragmas), extensionFlags, ms_hspp_opts, topDir, - WarningFlag(Opt_WarnUnrecognisedPragmas), wopt) import qualified Development.IDE.GHC.Compat.Util as EnumSet import "ghc-lib" GHC hiding @@ -84,11 +84,11 @@ import System.IO.Temp #else import Development.IDE.GHC.Compat hiding (setEnv) +import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) -import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) #endif import Ide.Logger @@ -557,7 +557,7 @@ applyHint ide nfp mhint = (anns', modu') <- ExceptT $ mapM (uncurry Refact.applyFixities) $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout - liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) + liftIO $ (Right <$> withRuntimeLibdir (Refact.applyRefactorings' position commands anns' modu')) `catches` errorHandlers #endif case res of From 0f590932ea84a768d369edd73d8d28ba1343965e Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 15:25:55 -0500 Subject: [PATCH 5/7] fix cpp --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 74794cd939..300c016ba0 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -542,7 +542,7 @@ applyHint ide nfp mhint = -- We have to reparse extensions to remove the invalid ones let (enabled, disabled, _invalid) = parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled - (Right <$> withRuntimeLibdir (applyRefactorings position commands temp refactExts)) + (Right <$> withRuntimeLibdir (Refact.applyRefactorings position commands temp refactExts)) `catches` errorHandlers #else mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp From 1c247fc5ba66c2f5e73b8a1b5ea1614e9ccbff50 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 15:32:34 -0500 Subject: [PATCH 6/7] fix cpp 2 --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 300c016ba0..a01818177f 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -540,7 +540,7 @@ applyHint ide nfp mhint = (pflags, _, _) <- runAction' $ useNoFile_ GetHlintSettings exts <- runAction' $ getExtensions pflags nfp -- We have to reparse extensions to remove the invalid ones - let (enabled, disabled, _invalid) = parseExtensions $ map show exts + let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled (Right <$> withRuntimeLibdir (Refact.applyRefactorings position commands temp refactExts)) `catches` errorHandlers From ecf0959ff7cda2fbbab03b665bc816b73a445b48 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 22 Jan 2022 16:02:56 -0500 Subject: [PATCH 7/7] actually fix pendantic warnings because import is not used when hlint_ghc_lib is on --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index a01818177f..76c44b6654 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -52,7 +52,6 @@ import Development.IDE.Core.Rules (defineNoFil usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) import qualified Refact.Apply as Refact -import qualified Refact.Fixity as Refact #ifdef HLINT_ON_GHC_LIB import Data.List (nub) @@ -89,6 +88,7 @@ import Language.Haskell.GHC.ExactPrint.Delta (deltaOption import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) +import qualified Refact.Fixity as Refact #endif import Ide.Logger