Code action add default type annotation to remove -Wtype-defaults warning (#680)

serhiip · web-flow · commit 9272bfe03021 · 2020-07-10T08:55:36.000+02:00
* 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
diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs
@@ -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
@@ -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
@@ -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:
diff --git a/test/exe/Main.hs b/test/exe/Main.hs
@@ -483,6 +483,7 @@ codeActionTests = testGroup "code actions"
   , deleteUnusedDefinitionTests
   , addInstanceConstraintTests
   , addFunctionConstraintTests
+  , addTypeAnnotationsToLiteralsTest
   ]
 
 codeLensesTests :: TestTree
@@ -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)
 
 
@@ -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
