Skip to content

Commit 4fc09fa

Browse files
jacgcocreature
authored andcommitted
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
1 parent 9a5ee23 commit 4fc09fa

File tree

4 files changed

+126
-2
lines changed

4 files changed

+126
-2
lines changed

.hlint.yaml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -81,7 +81,9 @@
8181
- Development.IDE.GHC.Compat
8282
- Development.IDE.GHC.Util
8383
- Development.IDE.Import.FindImports
84+
- Development.IDE.LSP.CodeAction
8485
- Development.IDE.Spans.Calculate
86+
- Main
8587

8688
- flags:
8789
- default: false

ghcide.cabal

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -171,6 +171,14 @@ test-suite ghcide-tests
171171
containers,
172172
extra,
173173
filepath,
174+
--------------------------------------------------------------
175+
-- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas
176+
-- which require depending on ghc. So the tests need to depend
177+
-- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a
178+
-- better solution can be found, but this is a quick solution
179+
-- which works for now.
180+
ghc,
181+
--------------------------------------------------------------
174182
haskell-lsp-types,
175183
lens,
176184
lsp-test,
@@ -179,6 +187,7 @@ test-suite ghcide-tests
179187
tasty-hunit,
180188
text
181189
hs-source-dirs: test/cabal test/exe test/src
190+
include-dirs: include
182191
ghc-options: -threaded
183192
main-is: Main.hs
184193
other-modules:

src/Development/IDE/LSP/CodeAction.hs

Lines changed: 43 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22
-- SPDX-License-Identifier: Apache-2.0
33

44
{-# LANGUAGE DuplicateRecordFields #-}
5+
{-# LANGUAGE CPP #-}
6+
#include "ghc-api-version.h"
57

68
-- | Go to the definition of a variable.
79
module Development.IDE.LSP.CodeAction
@@ -102,13 +104,52 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
102104
-- Could not find module ‘Data.Cha’
103105
-- Perhaps you meant Data.Char (from base-4.12.0.0)
104106
| "Could not find module" `T.isInfixOf` _message
105-
, "Perhaps you meant" `T.isInfixOf` _message
106-
= map proposeModule $ nubOrd $ findSuggestedModules _message where
107+
, "Perhaps you meant" `T.isInfixOf` _message = let
107108
findSuggestedModules = map (head . T.words) . drop 2 . T.lines
108109
proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
110+
in map proposeModule $ nubOrd $ findSuggestedModules _message
111+
112+
-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
113+
-- * Found hole: _ :: Int -> String
114+
-- * In the expression: _
115+
-- In the expression: _ a
116+
-- In an equation for ‘foo’: foo a = _ a
117+
-- * Relevant bindings include
118+
-- a :: Int
119+
-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)
120+
-- foo :: Int -> String
121+
-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
122+
-- Valid hole fits include
123+
-- foo :: Int -> String
124+
-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
125+
-- show :: forall a. Show a => a -> String
126+
-- with show @Int
127+
-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
128+
-- (and originally defined in ‘GHC.Show’))
129+
-- mempty :: forall a. Monoid a => a
130+
-- with mempty @(Int -> String)
131+
-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
132+
-- (and originally defined in ‘GHC.Base’)) (lsp-ui)
133+
134+
| topOfHoleFitsMarker `T.isInfixOf` _message = let
135+
findSuggestedHoleFits :: T.Text -> [T.Text]
136+
findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
137+
proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])
138+
holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
139+
dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
140+
selectLinesWithFits = filter ("::" `T.isInfixOf`)
141+
extractFitNames = map (T.strip . head . T.splitOn " :: ")
142+
in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
109143

110144
suggestAction _ _ = []
111145

146+
topOfHoleFitsMarker =
147+
#if MIN_GHC_API_VERSION(8,6,0)
148+
"Valid hole fits include"
149+
#else
150+
"Valid substitutions include"
151+
#endif
152+
112153
mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
113154
mkRenameEdit contents range name =
114155
if fromMaybe False maybeIsInfixFunction

test/exe/Main.hs

Lines changed: 72 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22
-- SPDX-License-Identifier: Apache-2.0
33

44
{-# LANGUAGE DuplicateRecordFields #-}
5+
{-# LANGUAGE CPP #-}
6+
#include "ghc-api-version.h"
57

68
module Main (main) where
79

@@ -232,6 +234,7 @@ codeActionTests = testGroup "code actions"
232234
, typeWildCardActionTests
233235
, removeImportTests
234236
, importRenameActionTests
237+
, fillTypedHoleTests
235238
]
236239

237240
renameActionTests :: TestTree
@@ -453,6 +456,75 @@ importRenameActionTests = testGroup "import rename actions"
453456
]
454457
liftIO $ expectedContentAfterAction @=? contentAfterAction
455458

459+
fillTypedHoleTests :: TestTree
460+
fillTypedHoleTests = let
461+
462+
sourceCode :: T.Text -> T.Text -> T.Text -> T.Text
463+
sourceCode a b c = T.unlines
464+
[ "module Testing where"
465+
, ""
466+
, "globalConvert :: Int -> String"
467+
, "globalConvert = undefined"
468+
, ""
469+
, "globalInt :: Int"
470+
, "globalInt = 3"
471+
, ""
472+
, "bar :: Int -> Int -> String"
473+
, "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where"
474+
, " localConvert = (flip replicate) 'x'"
475+
476+
]
477+
478+
check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
479+
check actionTitle
480+
oldA oldB oldC
481+
newA newB newC = testSession (T.unpack actionTitle) $ do
482+
let originalCode = sourceCode oldA oldB oldC
483+
let expectedCode = sourceCode newA newB newC
484+
doc <- openDoc' "Testing.hs" "haskell" originalCode
485+
_ <- waitForDiagnostics
486+
actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
487+
let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
488+
executeCodeAction chosenAction
489+
modifiedCode <- documentContents doc
490+
liftIO $ expectedCode @=? modifiedCode
491+
492+
pickActionWithTitle title actions = head
493+
[ action
494+
| CACodeAction action@CodeAction{ _title = actionTitle } <- actions
495+
, title == actionTitle ]
496+
497+
in
498+
testGroup "fill typed holes"
499+
[ check "replace hole `_` with show"
500+
"_" "n" "n"
501+
"show" "n" "n"
502+
503+
, check "replace hole `_` with globalConvert"
504+
"_" "n" "n"
505+
"globalConvert" "n" "n"
506+
507+
#if MIN_GHC_API_VERSION(8,6,0)
508+
, check "replace hole `_convertme` with localConvert"
509+
"_convertme" "n" "n"
510+
"localConvert" "n" "n"
511+
#endif
512+
513+
, check "replace hole `_b` with globalInt"
514+
"_a" "_b" "_c"
515+
"_a" "globalInt" "_c"
516+
517+
, check "replace hole `_c` with globalInt"
518+
"_a" "_b" "_c"
519+
"_a" "_b" "globalInt"
520+
521+
#if MIN_GHC_API_VERSION(8,6,0)
522+
, check "replace hole `_c` with parameterInt"
523+
"_a" "_b" "_c"
524+
"_a" "_b" "parameterInt"
525+
#endif
526+
]
527+
456528
----------------------------------------------------------------------
457529
-- Utils
458530

0 commit comments

Comments
 (0)