Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Commit

Permalink
Code action add default type annotation to remove -Wtype-defaults w…
Browse files Browse the repository at this point in the history 
…arning (#680)

* Code action to add default type annotation to satisfy the contraints

     this is useful when using `traceShow` with with OverloadedStrings
     and type-defaults warning enabled

     Handle the following cases:

            - there is one literal and one contraint to be satisfied

            - there are mulitple literals and/or multiple constraints

     Adding type annotations to expressions that trigger type-defaults
     warning is not part of this changes

* Simplify older test

* Fix hlint issue
  • Loading branch information
@serhiip
serhiip authored Jul 10, 2020
1 parent f32f666 commit 9272bfe
Show file tree
Hide file tree
Showing 2 changed files with 165 additions and 6 deletions.
57 changes: 57 additions & 0 deletions src/Development/IDE/Plugin/CodeAction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,7 @@ import GHC.LanguageExtensions.Type (Extension)
import Data.Function
import Control.Arrow ((>>>))
import Data.Functor
import Control.Applicative ((<|>))

plugin :: Plugin c
plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
Expand Down Expand Up @@ -146,6 +147,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat
, suggestReplaceIdentifier text diag
, suggestSignature True diag
, suggestConstraint text diag
, suggestAddTypeAnnotationToSatisfyContraints text diag
] ++ concat
[ suggestNewDefinition ideOptions pm text diag
++ suggestRemoveRedundantImport pm text diag
Expand Down Expand Up @@ -200,6 +202,61 @@ suggestDeleteTopBinding ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}
matchesBindingName b (SigD (TypeSig (L _ x:_) _)) = showSDocUnsafe (ppr x) == b
matchesBindingName _ _ = False


suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}
-- File.hs:52:41: warning:
-- * Defaulting the following constraint to type ‘Integer’
-- Num p0 arising from the literal ‘1’
-- * In the expression: 1
-- In an equation for ‘f’: f = 1
-- File.hs:52:41: warning:
-- * Defaulting the following constraints to type ‘[Char]’
-- (Show a0)
-- arising from a use of ‘traceShow’
-- at A.hs:228:7-25
-- (IsString a0)
-- arising from the literal ‘"debug"’
-- at A.hs:228:17-23
-- * In the expression: traceShow "debug" a
-- In an equation for ‘f’: f a = traceShow "debug" a
-- File.hs:52:41: warning:
-- * Defaulting the following constraints to type ‘[Char]’
-- (Show a0)
-- arising from a use of ‘traceShow’
-- at A.hs:255:28-43
-- (IsString a0)
-- arising from the literal ‘"test"’
-- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43
-- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’
-- In the expression: seq "test" seq "test" (traceShow "test")
-- In an equation for ‘f’:
-- f = seq "test" seq "test" (traceShow "test")
| Just [ty, lit] <- matchRegex _message (pat False False True)
<|> matchRegex _message (pat False False False)
= codeEdit ty lit (makeAnnotatedLit ty lit)
| Just source <- sourceOpt
, Just [ty, lit] <- matchRegex _message (pat True True False)
= let lit' = makeAnnotatedLit ty lit;
tir = textInRange _range source
in codeEdit ty lit (T.replace lit lit' tir)
| otherwise = []
where
makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"
pat multiple at inThe = T.concat [ ".*Defaulting the following constraint"
, if multiple then "s" else ""
, " to type ‘([^ ]+)’ "
, ".*arising from the literal ‘(.+)’"
, if inThe then ".+In the.+argument" else ""
, if at then ".+at" else ""
, ".+In the expression"
]
codeEdit ty lit replacement =
let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"
edits = [TextEdit _range replacement]
in [( title, edits )]


suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
-- File.hs:52:41: error:
Expand Down
114 changes: 108 additions & 6 deletions test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -483,6 +483,7 @@ codeActionTests = testGroup "code actions"
, deleteUnusedDefinitionTests
, addInstanceConstraintTests
, addFunctionConstraintTests
, addTypeAnnotationsToLiteralsTest
]

codeLensesTests :: TestTree
Expand Down Expand Up @@ -1209,9 +1210,104 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action"
liftIO $ contentAfterAction @?= expectedResult

extractCodeAction docId actionPrefix = do
Just (CACodeAction action@CodeAction { _title = actionTitle })
<- find (\(CACodeAction CodeAction{_title=x}) -> actionPrefix `T.isPrefixOf` x)
<$> getCodeActions docId (R 0 0 0 0)
[action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix]
return (action, actionTitle)

addTypeAnnotationsToLiteralsTest :: TestTree
addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints"
[
testSession "add default type to satisfy one contraint" $
testFor
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "module A () where"
, ""
, "f = 1"
])
[ (DsWarning, (3, 4), "Defaulting the following constraint") ]
"Add type annotation ‘Integer’ to ‘1’"
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "module A () where"
, ""
, "f = (1 :: Integer)"
])

, testSession "add default type to satisfy one contraint with duplicate literals" $
testFor
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "{-# LANGUAGE OverloadedStrings #-}"
, "module A () where"
, ""
, "import Debug.Trace"
, ""
, "f = seq \"debug\" traceShow \"debug\""
])
[ (DsWarning, (6, 8), "Defaulting the following constraint")
, (DsWarning, (6, 16), "Defaulting the following constraint")
]
"Add type annotation ‘[Char]’ to ‘\"debug\"’"
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "{-# LANGUAGE OverloadedStrings #-}"
, "module A () where"
, ""
, "import Debug.Trace"
, ""
, "f = seq (\"debug\" :: [Char]) traceShow \"debug\""
])
, testSession "add default type to satisfy two contraints" $
testFor
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "{-# LANGUAGE OverloadedStrings #-}"
, "module A () where"
, ""
, "import Debug.Trace"
, ""
, "f a = traceShow \"debug\" a"
])
[ (DsWarning, (6, 6), "Defaulting the following constraint") ]
"Add type annotation ‘[Char]’ to ‘\"debug\"’"
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "{-# LANGUAGE OverloadedStrings #-}"
, "module A () where"
, ""
, "import Debug.Trace"
, ""
, "f a = traceShow (\"debug\" :: [Char]) a"
])
, testSession "add default type to satisfy two contraints with duplicate literals" $
testFor
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "{-# LANGUAGE OverloadedStrings #-}"
, "module A () where"
, ""
, "import Debug.Trace"
, ""
, "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"
])
[ (DsWarning, (6, 54), "Defaulting the following constraint") ]
"Add type annotation ‘[Char]’ to ‘\"debug\"’"
(T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
, "{-# LANGUAGE OverloadedStrings #-}"
, "module A () where"
, ""
, "import Debug.Trace"
, ""
, "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))"
])
]
where
testFor source diag expectedTitle expectedResult = do
docId <- createDoc "A.hs" "haskell" source
expectDiagnostics [ ("A.hs", diag) ]

(action, title) <- extractCodeAction docId "Add type annotation"

liftIO $ title @?= expectedTitle
executeCodeAction action
contentAfterAction <- documentContents docId
liftIO $ contentAfterAction @?= expectedResult

extractCodeAction docId actionPrefix = do
[action@CodeAction { _title = actionTitle }] <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix]
return (action, actionTitle)


Expand Down Expand Up @@ -2684,19 +2780,25 @@ openTestDataDoc path = do
createDoc path "haskell" source

findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
findCodeActions doc range expectedTitles = do
findCodeActions = findCodeActions' (==) "is not a superset of"

findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of"

findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
findCodeActions' op errMsg doc range expectedTitles = do
actions <- getCodeActions doc range
let matches = sequence
[ listToMaybe
[ action
| CACodeAction action@CodeAction { _title = actionTitle } <- actions
, actionTitle == expectedTitle ]
, expectedTitle `op` actionTitle]
| expectedTitle <- expectedTitles]
let msg = show
[ actionTitle
| CACodeAction CodeAction { _title = actionTitle } <- actions
]
++ " is not a superset of "
++ " " <> errMsg <> " "
++ show expectedTitles
liftIO $ case matches of
Nothing -> assertFailure msg
Expand Down

0 comments on commit 9272bfe

Please sign in to comment.