diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index c3339d04de..32c7d640ad 100644 --- 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 index 87b18cfcbb..73de4078df 100644 --- 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