diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 4d079e8421..76c44b6654 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -51,16 +51,16 @@ import Development.IDE.Core.Rules (defineNoFil getParsedModuleWithComments, usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) -import Refact.Apply +import qualified Refact.Apply 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 @@ -83,11 +83,12 @@ 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)) +import qualified Refact.Fixity as Refact #endif import Ide.Logger @@ -539,9 +540,9 @@ 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 (applyRefactorings position commands temp refactExts)) + (Right <$> withRuntimeLibdir (Refact.applyRefactorings position commands temp refactExts)) `catches` errorHandlers #else mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp @@ -554,8 +555,9 @@ applyHint ide nfp mhint = -- apply-refact uses RigidLayout let rigidLayout = deltaOptions RigidLayout (anns', modu') <- - ExceptT $ return $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout - liftIO $ (Right <$> withRuntimeLibdir (applyRefactorings' position commands anns' modu')) + ExceptT $ mapM (uncurry Refact.applyFixities) + $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout + liftIO $ (Right <$> withRuntimeLibdir (Refact.applyRefactorings' position commands anns' modu')) `catches` errorHandlers #endif case res of diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 86bbfad319..69d92a28dc 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -7,7 +7,9 @@ module Main ) where import Control.Lens ((^.)) +import Control.Monad (when) 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 +32,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 \"" <> 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 +394,24 @@ 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 = do + 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 + when (isJust (codeAction ^. L.command)) $ + 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