Fix #2612 - hlint plugin - Apply fixities to parsed source before sending to apply-refact

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

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

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

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