Code actions for filling typed holes (#69)

* Add code action for filling type holes

* Incorporate hole name into action title

Useful if more than one hole appears on the same line. Not so useful
if both of these holes are just `_` rather than `_name` (or more than
one hole on the same line has the same `_name`): In which case perhaps
some numbers could be attached to the action titles, to distinguish
the holes. But I suspect that this would not be worth the effort.

* Add tests for fill-type-hole actions

* Disable two tests on GHC 8.4

These test hints about local bindings, whic GHC 8.4 does not provide.

* Replace compilerVersion with new MIN_GHC_API_VERSION macro

Author: jacg

.hlint.yaml

@@ -81,7 +81,9 @@
     - Development.IDE.GHC.Compat
     - Development.IDE.GHC.Util
     - Development.IDE.Import.FindImports
+    - Development.IDE.LSP.CodeAction
     - Development.IDE.Spans.Calculate
+    - Main
 
 - flags:
   - default: false

ghcide.cabal

@@ -171,6 +171,14 @@ test-suite ghcide-tests
         containers,
         extra,
         filepath,
+        --------------------------------------------------------------
+        -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas
+        -- which require depending on ghc. So the tests need to depend
+        -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a
+        -- better solution can be found, but this is a quick solution
+        -- which works for now.
+        ghc,
+        --------------------------------------------------------------
         haskell-lsp-types,
         lens,
         lsp-test,
@@ -179,6 +187,7 @@ test-suite ghcide-tests
         tasty-hunit,
         text
     hs-source-dirs: test/cabal test/exe test/src
+    include-dirs: include
     ghc-options: -threaded
     main-is: Main.hs
     other-modules:

src/Development/IDE/LSP/CodeAction.hs

@@ -2,6 +2,8 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE CPP #-}
+#include "ghc-api-version.h"
 
 -- | Go to the definition of a variable.
 module Development.IDE.LSP.CodeAction
@@ -102,13 +104,52 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
 --     Could not find module ‘Data.Cha’
 --     Perhaps you meant Data.Char (from base-4.12.0.0)
     | "Could not find module" `T.isInfixOf` _message
-    , "Perhaps you meant"     `T.isInfixOf` _message
-      = map proposeModule $ nubOrd $ findSuggestedModules _message where
+    , "Perhaps you meant"     `T.isInfixOf` _message = let
       findSuggestedModules = map (head . T.words) . drop 2 . T.lines
       proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
+      in map proposeModule $ nubOrd $ findSuggestedModules _message
+
+--  ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
+--   * Found hole: _ :: Int -> String
+--   * In the expression: _
+--     In the expression: _ a
+--     In an equation for ‘foo’: foo a = _ a
+--   * Relevant bindings include
+--       a :: Int
+--         (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)
+--       foo :: Int -> String
+--         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
+--     Valid hole fits include
+--       foo :: Int -> String
+--         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
+--       show :: forall a. Show a => a -> String
+--         with show @Int
+--         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
+--          (and originally defined in ‘GHC.Show’))
+--       mempty :: forall a. Monoid a => a
+--         with mempty @(Int -> String)
+--         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
+--          (and originally defined in ‘GHC.Base’)) (lsp-ui)
+
+    | topOfHoleFitsMarker `T.isInfixOf` _message = let
+      findSuggestedHoleFits :: T.Text -> [T.Text]
+      findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
+      proposeHoleFit name = ("replace hole `" <> holeName <>  "` with " <> name, [TextEdit _range name])
+      holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
+      dropPreceding       = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
+      selectLinesWithFits = filter ("::" `T.isInfixOf`)
+      extractFitNames     = map (T.strip . head . T.splitOn " :: ")
+      in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
 
 suggestAction _ _ = []
 
+topOfHoleFitsMarker =
+#if MIN_GHC_API_VERSION(8,6,0)
+  "Valid hole fits include"
+#else
+  "Valid substitutions include"
+#endif
+
 mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
 mkRenameEdit contents range name =
     if fromMaybe False maybeIsInfixFunction

test/exe/Main.hs

@@ -2,6 +2,8 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE CPP #-}
+#include "ghc-api-version.h"
 
 module Main (main) where
 
@@ -232,6 +234,7 @@ codeActionTests = testGroup "code actions"
   , typeWildCardActionTests
   , removeImportTests
   , importRenameActionTests
+  , fillTypedHoleTests
   ]
 
 renameActionTests :: TestTree
@@ -453,6 +456,75 @@ importRenameActionTests = testGroup "import rename actions"
             ]
       liftIO $ expectedContentAfterAction @=? contentAfterAction
 
+fillTypedHoleTests :: TestTree
+fillTypedHoleTests = let
+
+  sourceCode :: T.Text -> T.Text -> T.Text -> T.Text
+  sourceCode a b c = T.unlines
+    [ "module Testing where"
+      , ""
+      , "globalConvert :: Int -> String"
+      , "globalConvert = undefined"
+      , ""
+      , "globalInt :: Int"
+      , "globalInt = 3"
+      , ""
+      , "bar :: Int -> Int -> String"
+      , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"
+      , "  localConvert = (flip replicate) 'x'"
+
+    ]
+
+  check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
+  check actionTitle
+        oldA oldB oldC
+        newA newB newC =  testSession (T.unpack actionTitle) $ do
+    let originalCode = sourceCode oldA oldB oldC
+    let expectedCode = sourceCode newA newB newC
+    doc <- openDoc' "Testing.hs" "haskell" originalCode
+    _ <- waitForDiagnostics
+    actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
+    let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
+    executeCodeAction chosenAction
+    modifiedCode <- documentContents doc
+    liftIO $ expectedCode @=? modifiedCode
+
+  pickActionWithTitle title actions = head
+    [ action
+    | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
+    , title == actionTitle ]
+
+  in
+  testGroup "fill typed holes"
+  [ check "replace hole `_` with show"
+          "_"    "n" "n"
+          "show" "n" "n"
+
+  , check "replace hole `_` with globalConvert"
+          "_"             "n" "n"
+          "globalConvert" "n" "n"
+
+#if MIN_GHC_API_VERSION(8,6,0)
+  , check "replace hole `_convertme` with localConvert"
+          "_convertme"   "n" "n"
+          "localConvert" "n" "n"
+#endif
+
+  , check "replace hole `_b` with globalInt"
+          "_a" "_b"        "_c"
+          "_a" "globalInt" "_c"
+
+  , check "replace hole `_c` with globalInt"
+          "_a" "_b"        "_c"
+          "_a" "_b" "globalInt"
+
+#if MIN_GHC_API_VERSION(8,6,0)
+  , check "replace hole `_c` with parameterInt"
+          "_a" "_b" "_c"
+          "_a" "_b"  "parameterInt"
+#endif
+  ]
+
 ----------------------------------------------------------------------
 -- Utils