Avoid extra parens for wildcard type signature (#2764)

+ avoid parens in simple cases (a, Char, [a], (),...) - change one test - (Int)/Int Co-authored-by: Ondrej Sebek <[email protected]>
haskell · Mar 9, 2022 · 8a90def · 8a90def
1 parent 9f62337
commit 8a90def
Show file tree

Hide file tree

Showing 2 changed files with 79 additions and 73 deletions.
diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs
@@ -1529,14 +1529,22 @@ mkRenameEdit contents range name =
       curr <- textInRange range <$> contents
       pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
 
+
+-- | Extract the type and surround it in parentheses except in obviously safe cases.
+--
+-- Inferring when parentheses are actually needed around the type signature would
+-- require understanding both the precedence of the context of the hole and of
+-- the signature itself. Inserting them (almost) unconditionally is ugly but safe.
 extractWildCardTypeSignature :: T.Text -> T.Text
-extractWildCardTypeSignature =
-  -- inferring when parens are actually needed around the type signature would
-  -- require understanding both the precedence of the context of the _ and of
-  -- the signature itself. Inserting them unconditionally is ugly but safe.
-  ("(" `T.append`) . (`T.append` ")") .
-  T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
-  snd . T.breakOnEnd "standing for "
+extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature
+  where
+    msgSigPart = snd $ T.breakOnEnd "standing for " msg
+    signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart
+    -- parenthesize type applications, e.g. (Maybe Char)
+    application = any isSpace . T.unpack $ signature
+    -- do not add extra parentheses to lists, tuples and already parenthesized types
+    enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')]
+    bracket = ("(" `T.append`) . (`T.append` ")")
 
 extractRenamableTerms :: T.Text -> [T.Text]
 extractRenamableTerms msg

diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
@@ -1188,73 +1188,71 @@ renameActionTests = testGroup "rename actions"
 
 typeWildCardActionTests :: TestTree
 typeWildCardActionTests = testGroup "type wildcard actions"
-  [ testSession "global signature" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "func :: _"
-            , "func x = x"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getAllCodeActions doc
-      let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands
-                                   , "Use type signature" `T.isInfixOf` actionTitle
-                           ]
-      executeCodeAction addSignature
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "func :: (p -> p)"
-            , "func x = x"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "multi-line message" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "func :: _"
-            , "func x y = x + y"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getAllCodeActions doc
-      let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands
-                                    , "Use type signature" `T.isInfixOf` actionTitle
-                              ]
-      executeCodeAction addSignature
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "func :: (Integer -> Integer -> Integer)"
-            , "func x y = x + y"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "local signature" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "func :: Int -> Int"
-            , "func x ="
-            , "  let y :: _"
-            , "      y = x * 2"
-            , "  in y"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getAllCodeActions doc
-      let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands
-                                    , "Use type signature" `T.isInfixOf` actionTitle
-                              ]
-      executeCodeAction addSignature
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "func :: Int -> Int"
-            , "func x ="
-            , "  let y :: (Int)"
-            , "      y = x * 2"
-            , "  in y"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
+  [ testUseTypeSignature "global signature"
+        [ "func :: _"
+        , "func x = x"
+        ]
+        [ "func :: (p -> p)"
+        , "func x = x"
+        ]
+  , testUseTypeSignature "local signature"
+        [ "func :: Int -> Int"
+        , "func x ="
+        , "  let y :: _"
+        , "      y = x * 2"
+        , "  in y"
+        ]
+        [ "func :: Int -> Int"
+        , "func x ="
+        , "  let y :: Int"
+        , "      y = x * 2"
+        , "  in y"
+        ]
+  , testUseTypeSignature "multi-line message"
+        [ "func :: _"
+        , "func x y = x + y"
+        ]
+        [ "func :: (Integer -> Integer -> Integer)"
+        , "func x y = x + y"
+        ]
+  , testUseTypeSignature "type in parentheses"
+        [ "func :: a -> _"
+        , "func x = (x, const x)"
+        ]
+        [ "func :: a -> (a, b -> a)"
+        , "func x = (x, const x)"
+        ]
+  , testUseTypeSignature "type in brackets"
+        [ "func :: _ -> Maybe a"
+        , "func xs = head xs"
+        ]
+        [ "func :: [Maybe a] -> Maybe a"
+        , "func xs = head xs"
+        ]
+  , testUseTypeSignature "unit type"
+        [ "func :: IO _"
+        , "func = putChar 'H'"
+        ]
+        [ "func :: IO ()"
+        , "func = putChar 'H'"
+        ]
   ]
+  where
+    -- | Test session of given name, checking action "Use type signature..."
+    --   on a test file with given content and comparing to expected result.
+    testUseTypeSignature name textIn textOut = testSession name $ do
+        let fileStart = "module Testing where"
+            content = T.unlines $ fileStart : textIn
+            expectedContentAfterAction = T.unlines $ fileStart : textOut
+        doc <- createDoc "Testing.hs" "haskell" content
+        _ <- waitForDiagnostics
+        actionsOrCommands <- getAllCodeActions doc
+        let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands
+                                    , "Use type signature" `T.isInfixOf` actionTitle
+                            ]
+        executeCodeAction addSignature
+        contentAfterAction <- documentContents doc
+        liftIO $ expectedContentAfterAction @=? contentAfterAction
 
 {-# HLINT ignore "Use nubOrd" #-}
 removeImportTests :: TestTree