fix #2612. apply fixities to parsed source before sent to apply-refact

Author: eddiemundo

Diff for: 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 for: 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 for: 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 for: 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