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

* fix #2612. apply fixities to parsed source before sent to apply-refact * fix tests * dont hardcode getApplyHintText * try and fix pedantic warning * fix cpp * fix cpp 2 * actually fix pendantic warnings because import is not used when hlint_ghc_lib is on

Author: eddiemundo

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