Apply any hlint

src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs

@@ -21,8 +21,8 @@ import           Language.Haskell.Exts.Parser
 import           Language.Haskell.Exts.Extension
 import           Language.Haskell.HLint3           as Hlint
 import           Refact.Apply
-import           System.IO.Extra
 
+type HintTitle = T.Text
 -- ---------------------------------------------------------------------
 {-# ANN module ("HLint: ignore Eta reduce"         :: String) #-}
 {-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
@@ -46,16 +46,23 @@ applyRefactDescriptor = PluginDescriptor
 data ApplyOneParams = AOP
   { file      :: Uri
   , start_pos :: Position
+  -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them.
+  , hintTitle :: HintTitle
   } deriving (Eq,Show,Generic,FromJSON,ToJSON)
 
+data OneHint = OneHint
+  { oneHintPos :: Position
+  , oneHintTitle :: HintTitle
+  } deriving (Eq, Show)
+
 applyOneCmd :: CommandFunc ApplyOneParams WorkspaceEdit
-applyOneCmd = CmdSync $ \(AOP uri pos)-> do
-  applyOneCmd' uri pos
+applyOneCmd = CmdSync $ \(AOP uri pos title) -> do
+  applyOneCmd' uri (OneHint pos title)
 
-applyOneCmd' :: Uri -> Position -> IdeGhcM (IdeResponse WorkspaceEdit)
-applyOneCmd' uri pos = pluginGetFile "applyOne: " uri $ \fp -> do
+applyOneCmd' :: Uri -> OneHint -> IdeGhcM (IdeResponse WorkspaceEdit)
+applyOneCmd' uri oneHint = pluginGetFile "applyOne: " uri $ \fp -> do
       revMapp <- GM.mkRevRedirMapFunc
-      res <- GM.withMappedFile fp $ \file' -> liftIO $ applyHint file' (Just pos) revMapp
+      res <- GM.withMappedFile fp $ \file' -> liftIO $ applyHint file' (Just oneHint) revMapp
       logm $ "applyOneCmd:file=" ++ show fp
       logm $ "applyOneCmd:res=" ++ show res
       case res of
@@ -89,7 +96,6 @@ lintCmd = CmdSync $ \uri -> do
 lintCmd' :: Uri -> IdeGhcM (IdeResponse PublishDiagnosticsParams)
 lintCmd' uri = pluginGetFile "lintCmd: " uri $ \fp -> do
       res <- GM.withMappedFile fp $ \file' -> liftIO $ runExceptT $ runLintCmd file' []
-      -- logm $ "lint:res=" ++ show res
       case res of
         Left diags ->
           return (IdeResponseOk (PublishDiagnosticsParams (filePathToUri fp) $ List diags))
@@ -153,7 +159,7 @@ hintToDiagnostic idea
   = Diagnostic
       { _range    = ss2Range (ideaSpan idea)
       , _severity = Just (hintSeverityMap $ ideaSeverity idea)
-      , _code     = Nothing
+      , _code     = Just (T.pack $ ideaHint idea)
       , _source   = Just "hlint"
       , _message  = idea2Message idea
       }
@@ -198,23 +204,54 @@ ss2Range ss = Range ps pe
 
 -- ---------------------------------------------------------------------
 
-applyHint :: FilePath -> Maybe Position -> (FilePath -> FilePath) -> IO (Either String WorkspaceEdit)
-applyHint fp mpos fileMap = do
-  withTempFile $ \f -> do
-    let optsf = "-o " ++ f
-        opts = case mpos of
-                 Nothing -> optsf
-                 Just (Position l c) -> optsf ++ " --pos " ++ show (l+1) ++ "," ++ show (c+1)
-        hlintOpts = [fp, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
-    runExceptT $ do
-      ideas <- runHlint fp hlintOpts
-      liftIO $ logm $ "applyHint:ideas=" ++ show ideas
-      let commands = map (show &&& ideaRefactoring) ideas
-      appliedFile <- liftIO $ applyRefactorings (unPos <$> mpos) commands fp
-      diff <- liftIO $ makeDiffResult fp (T.pack appliedFile) fileMap
-      liftIO $ logm $ "applyHint:diff=" ++ show diff
-      return diff
-
+applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IO (Either String WorkspaceEdit)
+applyHint fp mhint fileMap = do
+  runExceptT $ do
+    ideas <- getIdeas fp mhint
+    let commands = map (show &&& ideaRefactoring) ideas
+    liftIO $ logm $ "applyHint:apply=" ++ show commands
+    -- set Nothing as "position" for "applyRefactorings" because
+    -- applyRefactorings expects the provided position to be _within_ the scope
+    -- of each refactoring it will apply.
+    -- But "Idea"s returned by HLint pont to starting position of the expressions
+    -- that contain refactorings, so they are often outside the refactorings' boundaries.
+    -- Example:
+    -- Given an expression "hlintTest = reid $ (myid ())"
+    -- Hlint returns an idea at the position (1,13)
+    -- That contains "Redundant brackets" refactoring at position (1,20):
+    --
+    -- [("src/App/Test.hs:5:13: Warning: Redundant bracket\nFound:\n  reid $ (myid ())\nWhy not:\n  reid $ myid ()\n",[Replace {rtype = Expr, pos = SrcSpan {startLine = 5, startCol = 20, endLine = 5, endCol = 29}, subts = [("x",SrcSpan {startLine = 5, startCol = 21, endLine = 5, endCol = 28})], orig = "x"}])]
+    --
+    -- If we provide "applyRefactorings" with "Just (1,13)" then
+    -- the "Redundant bracket" hint will never be executed
+    -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
+    appliedFile <- liftIO $ applyRefactorings Nothing commands fp
+    diff <- liftIO $ makeDiffResult fp (T.pack appliedFile) fileMap
+    liftIO $ logm $ "applyHint:diff=" ++ show diff
+    return diff
+
+-- | Gets HLint ideas for
+getIdeas :: FilePath -> Maybe OneHint -> ExceptT String IO [Idea]
+getIdeas lintFile mhint = do
+  let hOpts = hlintOpts lintFile (oneHintPos <$> mhint)
+  ideas <- runHlint lintFile hOpts
+  pure $ maybe ideas (`filterIdeas` ideas) mhint
+
+-- | If we are only interested in applying a particular hint then
+-- let's filter out all the irrelevant ideas
+filterIdeas :: OneHint -> [Idea] -> [Idea]
+filterIdeas (OneHint (Position l c) title) ideas =
+  let
+    title' = T.unpack title
+    ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan
+  in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas
+
+hlintOpts :: FilePath -> Maybe Position -> [String]
+hlintOpts lintFile mpos =
+  let
+    posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1)
+    opts = maybe "" posOpt mpos
+  in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ]
 
 runHlint :: FilePath -> [String] -> ExceptT String IO [Idea]
 runHlint fp args =

src/Haskell/Ide/Engine/Transport/LspStdio.hs

@@ -543,14 +543,14 @@ reactor (DispatcherEnv cancelReqTVar wipTVar versionTVar) cin inp = do
             (J.List diags) = params ^. J.context . J.diagnostics
 
         let
-          makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "hlint") m  ) = [J.Command title cmd cmdparams]
+          makeCommand (J.Diagnostic (J.Range start _) _s (Just code) (Just "hlint") m) = [J.Command title cmd cmdparams]
             where
               title :: T.Text
               title = "Apply hint:" <> head (T.lines m)
               -- NOTE: the cmd needs to be registered via the InitializeResponse message. See hieOptions above
               cmd = "applyrefact:applyOne"
-              -- need 'file' and 'start_pos'
-              args = J.Array $ V.singleton $ J.toJSON $ ApplyRefact.AOP doc start
+              -- need 'file', 'start_pos' and hint title (to distinguish between alternative suggestions at the same location)
+              args = J.Array $ V.singleton $ J.toJSON $ ApplyRefact.AOP doc start code
               cmdparams = Just args
           makeCommand (J.Diagnostic _r _s _c _source _m  ) = []
           -- TODO: make context specific commands for all sorts of things, such as refactorings

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-11.2
+resolver: lts-11.6
 packages:
 - .
 - hie-plugin-api

test/ApplyRefactPluginSpec.hs

@@ -13,6 +13,8 @@ import           TestUtils
 
 import           Test.Hspec
 
+{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
+
 -- ---------------------------------------------------------------------
 
 main :: IO ()
@@ -39,9 +41,8 @@ applyRefactSpec = do
     it "applies one hint only" $ do
 
       let furi = filePathToUri "./test/testdata/ApplyRefact.hs"
-          act = applyOneCmd' furi
-                             (toPos (2,8))
-          arg = AOP furi (toPos (2,8))
+          act = applyOneCmd' furi (OneHint (toPos (2,8)) "Redundant bracket")
+          arg = AOP furi (toPos (2,8)) "Redundant bracket"
           res = IdeResponseOk $ WorkspaceEdit
             (Just $ H.singleton applyRefactPath
                                 $ List [TextEdit (Range (Position 1 0) (Position 1 25))
@@ -77,12 +78,12 @@ applyRefactSpec = do
              , _diagnostics = List $
                [ Diagnostic (Range (Position 1 7) (Position 1 25))
                             (Just DsHint)
-                            Nothing
+                            (Just "Redundant bracket")
                             (Just "hlint")
                             "Redundant bracket\nFound:\n  (putStrLn \"hello\")\nWhy not:\n  putStrLn \"hello\"\n"
                , Diagnostic (Range (Position 3 8) (Position 3 15))
                             (Just DsHint)
-                            Nothing
+                            (Just "Redundant bracket")
                             (Just "hlint")
                             "Redundant bracket\nFound:\n  (x + 1)\nWhy not:\n  x + 1\n"
                ]}
@@ -119,7 +120,7 @@ applyRefactSpec = do
             , _diagnostics = List
               [ Diagnostic (Range (Position 3 11) (Position 3 20))
                            (Just DsInfo)
-                           Nothing
+                           (Just "Redundant bracket")
                            (Just "hlint")
                            "Redundant bracket\nFound:\n  (\"hello\")\nWhy not:\n  \"hello\"\n"
               ]

test/Functional.hs

@@ -51,6 +51,7 @@ import           Haskell.Ide.Engine.Plugin.Example2
 import           Haskell.Ide.Engine.Plugin.GhcMod
 import           Haskell.Ide.Engine.Plugin.HaRe
 
+{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
 -- ---------------------------------------------------------------------
 
 plugins :: IdePlugins
@@ -124,7 +125,7 @@ functionalSpec = do
                               , _diagnostics = List
                                 [ Diagnostic (Range (Position 9 6) (Position 10 18))
                                              (Just DsInfo)
-                                             Nothing
+                                             (Just "Redundant do")
                                              (Just "hlint")
                                              "Redundant do\nFound:\n  do putStrLn \"hello\"\nWhy not:\n  putStrLn \"hello\"\n"
                                 ]

test/JsonSpec.hs

@@ -20,6 +20,8 @@ import           Test.QuickCheck.Instances     ()
 -- import Debug.Trace
 -- ---------------------------------------------------------------------
 
+{-# ANN module ("HLint: ignore Redundant do"       :: String) #-}
+
 main :: IO ()
 main = hspec spec
 
@@ -48,16 +50,14 @@ propertyJsonRoundtrip a = Success a == fromJSON (toJSON a)
 
 -- enough for our needs
 instance Arbitrary Value where
-  arbitrary = do
-    s <- arbitrary
-    return $ String s
+  arbitrary = String <$> arbitrary
 
 -- | make lists of maximum length 3 for test performance
 smallList :: Gen a -> Gen [a]
 smallList = resize 3 . listOf
 
 instance Arbitrary ApplyOneParams where
-  arbitrary = AOP <$> arbitrary <*> arbitrary
+  arbitrary = AOP <$> arbitrary <*> arbitrary <*>  arbitrary
 
 instance Arbitrary InfoParams where
   arbitrary = IP <$> arbitrary <*> arbitrary