Skip to content

Commit 7cc91dc

Browse files
DenisFrezzatoDenisFrezzato
authored
Code action: add constraint (#653)
* Add missing instance constraint * Add missing instance constraint with existing constraints * Add missing function constraint * Add missing function consraint with existing constraints * Add some comments * Improve type signature regex * Remove redundant bracket * Improve missing constraint searching. Create entrypoint for missing constraint code action, in order to have a more efficient parsing by routing to the relevant implementation. Fix type signature name parsing. Minor refactor. * Minor refactor
1 parent bd51ad0 commit 7cc91dc

File tree

2 files changed

+264
-0
lines changed

2 files changed

+264
-0
lines changed

‎src/Development/IDE/Plugin/CodeAction.hs

+138
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,9 @@ import Outputable (ppr, showSDocUnsafe)
5656
import DynFlags (xFlags, FlagSpec(..))
5757
import GHC.LanguageExtensions.Type (Extension)
5858
import System.Time.Extra (showDuration, duration)
59+
import Data.Function
60+
import Control.Arrow ((>>>))
61+
import Data.Functor
5962

6063
plugin :: Plugin c
6164
plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
@@ -155,6 +158,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat
155158
, suggestModuleTypo diag
156159
, suggestReplaceIdentifier text diag
157160
, suggestSignature True diag
161+
, suggestConstraint text diag
158162
] ++ concat
159163
[ suggestNewDefinition ideOptions pm text diag
160164
++ suggestRemoveRedundantImport pm text diag
@@ -404,6 +408,140 @@ suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
404408

405409
suggestSignature _ _ = []
406410

411+
-- | Suggests a constraint for a declaration for which a constraint is missing.
412+
suggestConstraint :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
413+
suggestConstraint mContents diag@Diagnostic {..}
414+
| Just contents <- mContents
415+
, Just missingConstraint <- findMissingConstraint _message
416+
= let codeAction = if _message =~ ("the type signature for:" :: String)
417+
then suggestFunctionConstraint
418+
else suggestInstanceConstraint
419+
in codeAction contents diag missingConstraint
420+
| otherwise = []
421+
where
422+
findMissingConstraint :: T.Text -> Maybe T.Text
423+
findMissingConstraint t =
424+
let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from a use of"
425+
in matchRegex t regex <&> last
426+
427+
normalizeConstraints :: T.Text -> T.Text -> T.Text
428+
normalizeConstraints existingConstraints constraint =
429+
let constraintsInit = if "(" `T.isPrefixOf` existingConstraints
430+
then T.dropEnd 1 existingConstraints
431+
else "(" <> existingConstraints
432+
in constraintsInit <> ", " <> constraint <> ")"
433+
434+
-- | Suggests a constraint for an instance declaration for which a constraint is missing.
435+
suggestInstanceConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])]
436+
suggestInstanceConstraint contents Diagnostic {..} missingConstraint
437+
-- Suggests a constraint for an instance declaration with no existing constraints.
438+
-- • No instance for (Eq a) arising from a use of ‘==’
439+
-- Possible fix: add (Eq a) to the context of the instance declaration
440+
-- • In the expression: x == y
441+
-- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y
442+
-- In the instance declaration for ‘Eq (Wrap a)’
443+
| Just [instanceDeclaration] <- matchRegex _message "In the instance declaration for ‘([^`]*)’"
444+
= let instanceLine = contents
445+
& T.splitOn ("instance " <> instanceDeclaration)
446+
& head & T.lines & length
447+
startOfConstraint = Position instanceLine (length ("instance " :: String))
448+
range = Range startOfConstraint startOfConstraint
449+
newConstraint = missingConstraint <> " => "
450+
in [(actionTitle missingConstraint, [TextEdit range newConstraint])]
451+
452+
-- Suggests a constraint for an instance declaration with one or more existing constraints.
453+
-- • Could not deduce (Eq b) arising from a use of ‘==’
454+
-- from the context: Eq a
455+
-- bound by the instance declaration at /path/to/Main.hs:7:10-32
456+
-- Possible fix: add (Eq b) to the context of the instance declaration
457+
-- • In the second argument of ‘(&&)’, namely ‘x' == y'’
458+
-- In the expression: x == y && x' == y'
459+
-- In an equation for ‘==’:
460+
-- (Pair x x') == (Pair y y') = x == y && x' == y'
461+
| Just [instanceLineStr, constraintFirstCharStr]
462+
<- matchRegex _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"
463+
= let existingConstraints = findExistingConstraints _message
464+
newConstraints = normalizeConstraints existingConstraints missingConstraint
465+
instanceLine = readPositionNumber instanceLineStr
466+
constraintFirstChar = readPositionNumber constraintFirstCharStr
467+
startOfConstraint = Position instanceLine constraintFirstChar
468+
endOfConstraint = Position instanceLine $
469+
constraintFirstChar + T.length existingConstraints
470+
range = Range startOfConstraint endOfConstraint
471+
in [(actionTitle missingConstraint, [TextEdit range newConstraints])]
472+
| otherwise = []
473+
where
474+
findExistingConstraints :: T.Text -> T.Text
475+
findExistingConstraints t =
476+
T.replace "from the context: " "" . T.strip $ T.lines t !! 1
477+
478+
readPositionNumber :: T.Text -> Int
479+
readPositionNumber = T.unpack >>> read >>> pred
480+
481+
actionTitle :: T.Text -> T.Text
482+
actionTitle constraint = "Add `" <> constraint
483+
<> "` to the context of the instance declaration"
484+
485+
findTypeSignatureName :: T.Text -> Maybe T.Text
486+
findTypeSignatureName t = matchRegex t "([^ ]+) :: " <&> head
487+
488+
findTypeSignatureLine :: T.Text -> T.Text -> Int
489+
findTypeSignatureLine contents typeSignatureName =
490+
T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length
491+
492+
-- | Suggests a constraint for a type signature for which a constraint is missing.
493+
suggestFunctionConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])]
494+
suggestFunctionConstraint contents Diagnostic{..} missingConstraint
495+
-- Suggests a constraint for a type signature with any number of existing constraints.
496+
-- • No instance for (Eq a) arising from a use of ‘==’
497+
-- Possible fix:
498+
-- add (Eq a) to the context of
499+
-- the type signature for:
500+
-- eq :: forall a. a -> a -> Bool
501+
-- • In the expression: x == y
502+
-- In an equation for ‘eq’: eq x y = x == y
503+
504+
-- • Could not deduce (Eq b) arising from a use of ‘==’
505+
-- from the context: Eq a
506+
-- bound by the type signature for:
507+
-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool
508+
-- at Main.hs:5:1-42
509+
-- Possible fix:
510+
-- add (Eq b) to the context of
511+
-- the type signature for:
512+
-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool
513+
-- • In the second argument of ‘(&&)’, namely ‘y == y'’
514+
-- In the expression: x == x' && y == y'
515+
-- In an equation for ‘eq’:
516+
-- eq (Pair x y) (Pair x' y') = x == x' && y == y'
517+
| Just typeSignatureName <- findTypeSignatureName _message
518+
= let mExistingConstraints = findExistingConstraints _message
519+
newConstraint = buildNewConstraints missingConstraint mExistingConstraints
520+
typeSignatureLine = findTypeSignatureLine contents typeSignatureName
521+
typeSignatureFirstChar = T.length $ typeSignatureName <> " :: "
522+
startOfConstraint = Position typeSignatureLine typeSignatureFirstChar
523+
endOfConstraint = Position typeSignatureLine $
524+
typeSignatureFirstChar + maybe 0 T.length mExistingConstraints
525+
range = Range startOfConstraint endOfConstraint
526+
in [(actionTitle missingConstraint typeSignatureName, [TextEdit range newConstraint])]
527+
| otherwise = []
528+
where
529+
findExistingConstraints :: T.Text -> Maybe T.Text
530+
findExistingConstraints message =
531+
if message =~ ("from the context:" :: String)
532+
then fmap (T.strip . head) $ matchRegex message "\\. ([^=]+)"
533+
else Nothing
534+
535+
buildNewConstraints :: T.Text -> Maybe T.Text -> T.Text
536+
buildNewConstraints constraint mExistingConstraints =
537+
case mExistingConstraints of
538+
Just existingConstraints -> normalizeConstraints existingConstraints constraint
539+
Nothing -> constraint <> " => "
540+
541+
actionTitle :: T.Text -> T.Text -> T.Text
542+
actionTitle constraint typeSignatureName = "Add `" <> constraint
543+
<> "` to the context of the type signature for `" <> typeSignatureName <> "`"
544+
407545
-------------------------------------------------------------------------------------------------
408546

409547
suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]

‎test/exe/Main.hs

+126
Original file line numberDiff line numberDiff line change
@@ -481,6 +481,8 @@ codeActionTests = testGroup "code actions"
481481
, addSigActionTests
482482
, insertNewDefinitionTests
483483
, deleteUnusedDefinitionTests
484+
, addInstanceConstraintTests
485+
, addFunctionConstraintTests
484486
]
485487

486488
codeLensesTests :: TestTree
@@ -1328,6 +1330,130 @@ fillTypedHoleTests = let
13281330
#endif
13291331
]
13301332

1333+
addInstanceConstraintTests :: TestTree
1334+
addInstanceConstraintTests = let
1335+
missingConstraintSourceCode :: Maybe T.Text -> T.Text
1336+
missingConstraintSourceCode mConstraint =
1337+
let constraint = maybe "" (<> " => ") mConstraint
1338+
in T.unlines
1339+
[ "module Testing where"
1340+
, ""
1341+
, "data Wrap a = Wrap a"
1342+
, ""
1343+
, "instance " <> constraint <> "Eq (Wrap a) where"
1344+
, " (Wrap x) == (Wrap y) = x == y"
1345+
]
1346+
1347+
incompleteConstraintSourceCode :: Maybe T.Text -> T.Text
1348+
incompleteConstraintSourceCode mConstraint =
1349+
let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint
1350+
in T.unlines
1351+
[ "module Testing where"
1352+
, ""
1353+
, "data Pair a b = Pair a b"
1354+
, ""
1355+
, "instance " <> constraint <> " => Eq (Pair a b) where"
1356+
, " (Pair x y) == (Pair x' y') = x == x' && y == y'"
1357+
]
1358+
1359+
incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text
1360+
incompleteConstraintSourceCode2 mConstraint =
1361+
let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint
1362+
in T.unlines
1363+
[ "module Testing where"
1364+
, ""
1365+
, "data Three a b c = Three a b c"
1366+
, ""
1367+
, "instance " <> constraint <> " => Eq (Three a b c) where"
1368+
, " (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'"
1369+
]
1370+
1371+
check :: T.Text -> T.Text -> T.Text -> TestTree
1372+
check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do
1373+
doc <- createDoc "Testing.hs" "haskell" originalCode
1374+
_ <- waitForDiagnostics
1375+
actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 68))
1376+
chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1377+
executeCodeAction chosenAction
1378+
modifiedCode <- documentContents doc
1379+
liftIO $ expectedCode @=? modifiedCode
1380+
1381+
in testGroup "add instance constraint"
1382+
[ check
1383+
"Add `Eq a` to the context of the instance declaration"
1384+
(missingConstraintSourceCode Nothing)
1385+
(missingConstraintSourceCode $ Just "Eq a")
1386+
, check
1387+
"Add `Eq b` to the context of the instance declaration"
1388+
(incompleteConstraintSourceCode Nothing)
1389+
(incompleteConstraintSourceCode $ Just "Eq b")
1390+
, check
1391+
"Add `Eq c` to the context of the instance declaration"
1392+
(incompleteConstraintSourceCode2 Nothing)
1393+
(incompleteConstraintSourceCode2 $ Just "Eq c")
1394+
]
1395+
1396+
addFunctionConstraintTests :: TestTree
1397+
addFunctionConstraintTests = let
1398+
missingConstraintSourceCode :: Maybe T.Text -> T.Text
1399+
missingConstraintSourceCode mConstraint =
1400+
let constraint = maybe "" (<> " => ") mConstraint
1401+
in T.unlines
1402+
[ "module Testing where"
1403+
, ""
1404+
, "eq :: " <> constraint <> "a -> a -> Bool"
1405+
, "eq x y = x == y"
1406+
]
1407+
1408+
incompleteConstraintSourceCode :: Maybe T.Text -> T.Text
1409+
incompleteConstraintSourceCode mConstraint =
1410+
let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")") mConstraint
1411+
in T.unlines
1412+
[ "module Testing where"
1413+
, ""
1414+
, "data Pair a b = Pair a b"
1415+
, ""
1416+
, "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"
1417+
, "eq (Pair x y) (Pair x' y') = x == x' && y == y'"
1418+
]
1419+
1420+
incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text
1421+
incompleteConstraintSourceCode2 mConstraint =
1422+
let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")") mConstraint
1423+
in T.unlines
1424+
[ "module Testing where"
1425+
, ""
1426+
, "data Three a b c = Three a b c"
1427+
, ""
1428+
, "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool"
1429+
, "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'"
1430+
]
1431+
1432+
check :: T.Text -> T.Text -> T.Text -> TestTree
1433+
check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do
1434+
doc <- createDoc "Testing.hs" "haskell" originalCode
1435+
_ <- waitForDiagnostics
1436+
actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound))
1437+
chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1438+
executeCodeAction chosenAction
1439+
modifiedCode <- documentContents doc
1440+
liftIO $ expectedCode @=? modifiedCode
1441+
1442+
in testGroup "add function constraint"
1443+
[ check
1444+
"Add `Eq a` to the context of the type signature for `eq`"
1445+
(missingConstraintSourceCode Nothing)
1446+
(missingConstraintSourceCode $ Just "Eq a")
1447+
, check
1448+
"Add `Eq b` to the context of the type signature for `eq`"
1449+
(incompleteConstraintSourceCode Nothing)
1450+
(incompleteConstraintSourceCode $ Just "Eq b")
1451+
, check
1452+
"Add `Eq c` to the context of the type signature for `eq`"
1453+
(incompleteConstraintSourceCode2 Nothing)
1454+
(incompleteConstraintSourceCode2 $ Just "Eq c")
1455+
]
1456+
13311457
addSigActionTests :: TestTree
13321458
addSigActionTests = let
13331459
header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"

0 commit comments

Comments
 (0)