fd163cd · ghcide · git.iko.soy

git.iko.soy/ghcide

Insert imports code action (#295)

* #46 Code action to add suggested imports * code action to fix constructor imports * #46 Add test for (broken) constructor import

commitfd163cd8e9f762b348acc97987226d9870cfc4a4 authorPepe Iborra <pepeiborra@gmail.com> dateMon 6 Jan 2020, 08:37 (7 years ago) parentf8e6ab1

3 files changed+274−8

compare with master

unifiedsplit

src/Development/IDE/LSP/CodeAction.hs+81−7 src/Development/IDE/Types/Location.hs+43−1 test/exe/Main.hs+150

src/Development/IDE/LSP/CodeAction.hs+81−7

@@ -16,6 +16,7 @@ import Development.IDE.GHC.Compat

1616import Development.IDE.Core.Rules

1717import Development.IDE.Core.RuleTypes

1818import Development.IDE.Core.Shake

19+import Development.IDE.GHC.Error

1920import Development.IDE.LSP.Server

2021import Development.IDE.Types.Location

2122import qualified Data.HashMap.Strict as Map

@@ -85,8 +86,22 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

8586 | otherwise

8687 = return (Null, Nothing)

8788

88−suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

89−suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

89+suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

90+suggestAction text diag = concat

91+ [ suggestAddExtension diag

92+ , suggestExtendImport text diag

93+ , suggestFillHole diag

94+ , suggestFillTypeWildcard diag

95+ , suggestFixConstructorImport text diag

96+ , suggestModuleTypo diag

97+ , suggestRemoveRedundantImport text diag

98+ , suggestReplaceIdentifier text diag

99+ , suggestSignature True diag

100+ ]

101+

102+

103+suggestRemoveRedundantImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

104+suggestRemoveRedundantImport contents Diagnostic{_range=_range@Range{..},..}

90105-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant

91106 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"

92107 , Just c <- contents

@@ -100,7 +115,10 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

100115-- To import instances alone, use: import Data.List()

101116 | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)

102117 = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]

118+ | otherwise = []

103119

120+suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

121+suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}

104122-- File.hs:52:41: error:

105123-- * Variable not in scope:

106124-- suggestAcion :: Maybe T.Text -> Range -> Range

@@ -114,7 +132,10 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

114132-- Module ‘Data.Text’ does not export ‘isPrfixOf’.

115133 | renameSuggestions@(_:_) <- extractRenamableTerms _message

116134 = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]

135+ | otherwise = []

117136

137+suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]

138+suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}

118139-- Foo.hs:3:8: error:

119140-- * Found type wildcard `_' standing for `p -> p1 -> p'

120141

@@ -122,7 +143,10 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

122143 , " standing for " `T.isInfixOf` _message

123144 , typeSignature <- extractWildCardTypeSignature _message

124145 = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]

146+ | otherwise = []

125147

148+suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]

149+suggestAddExtension Diagnostic{_range=_range@Range{..},..}

126150-- File.hs:22:8: error:

127151-- Illegal lambda-case (use -XLambdaCase)

128152-- File.hs:22:6: error:

@@ -145,7 +169,10 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

145169-- In the instance declaration for `Unit (m a)'

146170 | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message

147171 = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]

172+ | otherwise = []

148173

174+suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]

175+suggestModuleTypo Diagnostic{_range=_range@Range{..},..}

149176-- src/Development/IDE/Core/Compile.hs:58:1: error:

150177-- Could not find module ‘Data.Cha’

151178-- Perhaps you meant Data.Char (from base-4.12.0.0)

@@ -154,7 +181,10 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

154181 findSuggestedModules = map (head . T.words) . drop 2 . T.lines

155182 proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])

156183 in map proposeModule $ nubOrd $ findSuggestedModules _message

184+ | otherwise = []

157185

186+suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]

187+suggestFillHole Diagnostic{_range=_range@Range{..},..}

158188-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

159189-- * Found hole: _ :: Int -> String

160190-- * In the expression: _

@@ -187,9 +217,36 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

187217 extractFitNames = map (T.strip . head . T.splitOn " :: ")

188218 in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

189219

190− | tlb@[_] <- suggestSignature True diag = tlb

220+ | otherwise = []

191221

192−suggestAction _ _ = []

222+suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

223+suggestExtendImport contents Diagnostic{_range=_range,..}

224+ | Just [binding, mod, srcspan] <-

225+ matchRegex _message

226+ "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\$(.*)\$.$"

227+ , Just c <- contents

228+ = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of

229+ [s] -> let x = srcSpanToRange s

230+ in x{_end = (_end x){_character = succ (_character (_end x))}}

231+ _ -> error "bug in srcspan parser"

232+ importLine = textInRange range c

233+ in [("Add " <> binding <> " to the import list of " <> mod

234+ , [TextEdit range (addBindingToImportList binding importLine)])]

235+ | otherwise = []

236+

237+suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

238+suggestFixConstructorImport _ Diagnostic{_range=_range,..}

239+ -- ‘Success’ is a data constructor of ‘Result’

240+ -- To import it use

241+ -- import Data.Aeson.Types( Result( Success ) )

242+ -- or

243+ -- import Data.Aeson.Types( Result(..) ) (lsp-ui)

244+ | Just [constructor, typ] <-

245+ matchRegex _message

246+ "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"

247+ = let fixedImport = typ <> "(" <> constructor <> ")"

248+ in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]

249+ | otherwise = []

193250

194251suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

195252suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

@@ -282,6 +339,7 @@ splitTextAtPosition (Position row col) x

282339 = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)

283340 | otherwise = (x, T.empty)

284341

342+-- | Returns [start .. end[

285343textInRange :: Range -> T.Text -> T.Text

286344textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =

287345 case compare startRow endRow of

@@ -338,11 +396,27 @@ dropBindingsFromImportLine bindings_ importLine =

338396 joinCloseParens (x : rest) = x : joinCloseParens rest

339397 joinCloseParens [] = []

340398

399+-- | Extends an import list with a new binding.

400+-- Assumes an import statement of the form:

401+-- import (qualified) A (..) ..

402+-- Places the new binding first, preserving whitespace.

403+-- Copes with multi-line import lists

404+addBindingToImportList :: T.Text -> T.Text -> T.Text

405+addBindingToImportList binding importLine = case T.breakOn "(" importLine of

406+ (pre, T.uncons -> Just (_, rest)) ->

407+ case T.uncons (T.dropWhile isSpace rest) of

408+ Just (')', _) -> T.concat [pre, "(", binding, rest]

409+ _ -> T.concat [pre, "(", binding, ", ", rest]

410+ _ ->

411+ error

412+ $ "importLine does not have the expected structure: "

413+ <> T.unpack importLine

414+

341415-- | Returns Just (the submatches) for the first capture, or Nothing.

342416matchRegex :: T.Text -> T.Text -> Maybe [T.Text]

343−matchRegex message regex = case message =~~ regex of

344− Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings

345− Nothing -> Nothing

417+matchRegex message regex = case T.unwords (T.words message) =~~ regex of

418+ Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings

419+ Nothing -> Nothing

346420

347421setHandlersCodeAction :: PartialHandlers

348422setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{

src/Development/IDE/Types/Location.hs+43−1

@@ -21,15 +21,19 @@ module Development.IDE.Types.Location

2121 , filePathToUri

2222 , filePathToUri'

2323 , uriToFilePath'

24+ , readSrcSpan

2425 ) where

2526

27+import Control.Applicative

2628import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))

2729import Control.DeepSeq

30+import Control.Monad

2831import Data.Binary

2932import Data.Maybe as Maybe

3033import Data.Hashable

3134import Data.String

3235import qualified Data.Text as T

36+import FastString

3337import Network.URI

3438import System.FilePath

3539import qualified System.FilePath.Posix as FPP

@@ -43,6 +47,8 @@ import Language.Haskell.LSP.Types as LSP (

4347 , toNormalizedUri

4448 , fromNormalizedUri

4549 )

50+import GHC

51+import Text.ParserCombinators.ReadP as ReadP

4652

4753

4854-- | Newtype wrapper around FilePath that always has normalized slashes.

@@ -120,6 +126,42 @@ noFilePath = "<unknown>"

120126noRange :: Range

121127noRange = Range (Position 0 0) (Position 100000 0)

122128

123−

124129showPosition :: Position -> String

125130showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)

131+

132+-- | Parser for the GHC output format

133+readSrcSpan :: ReadS SrcSpan

134+readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)

135+ where

136+ singleLineSrcSpanP, multiLineSrcSpanP :: ReadP SrcSpan

137+ singleLineSrcSpanP = do

138+ fp <- filePathP

139+ l <- readS_to_P reads <* char ':'

140+ c0 <- readS_to_P reads

141+ c1 <- (char '-' *> readS_to_P reads) <|> pure c0

142+ let from = mkSrcLoc fp l c0

143+ to = mkSrcLoc fp l c1

144+ return $ mkSrcSpan from to

145+

146+ multiLineSrcSpanP = do

147+ fp <- filePathP

148+ s <- parensP (srcLocP fp)

149+ void $ char '-'

150+ e <- parensP (srcLocP fp)

151+ return $ mkSrcSpan s e

152+

153+ parensP :: ReadP a -> ReadP a

154+ parensP = between (char '(') (char ')')

155+

156+ filePathP :: ReadP FastString

157+ filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""

158+

159+ srcLocP :: FastString -> ReadP SrcLoc

160+ srcLocP fp = do

161+ l <- readS_to_P reads

162+ void $ char ','

163+ c <- readS_to_P reads

164+ return $ mkSrcLoc fp l c

165+

166+ readFilePath :: ReadP FilePath

167+ readFilePath = some ReadP.get

test/exe/Main.hs+150

@@ -14,6 +14,7 @@ import Control.Monad

1414import Control.Monad.IO.Class (liftIO)

1515import Data.Char (toLower)

1616import Data.Foldable

17+import Data.List

1718import Development.IDE.GHC.Util

1819import qualified Data.Text as T

1920import Development.IDE.Test

@@ -389,6 +390,8 @@ codeActionTests = testGroup "code actions"

389390 [ renameActionTests

390391 , typeWildCardActionTests

391392 , removeImportTests

393+ , extendImportTests

394+ , fixConstructorImportTests

392395 , importRenameActionTests

393396 , fillTypedHoleTests

394397 , addSigActionTests

@@ -689,6 +692,153 @@ removeImportTests = testGroup "remove import actions"

689692 liftIO $ expectedContentAfterAction @=? contentAfterAction

690693 ]

691694

695+extendImportTests :: TestTree

696+extendImportTests = testGroup "extend import actions"

697+ [ testSession "extend single line import with value" $ template

698+ (T.unlines

699+ [ "module ModuleA where"

700+ , "stuffA :: Double"

701+ , "stuffA = 0.00750"

702+ , "stuffB :: Integer"

703+ , "stuffB = 123"

704+ ])

705+ (T.unlines

706+ [ "module ModuleB where"

707+ , "import ModuleA as A (stuffB)"

708+ , "main = print (stuffA, stuffB)"

709+ ])

710+ (Range (Position 3 17) (Position 3 18))

711+ "Add stuffA to the import list of ModuleA"

712+ (T.unlines

713+ [ "module ModuleB where"

714+ , "import ModuleA as A (stuffA, stuffB)"

715+ , "main = print (stuffA, stuffB)"

716+ ])

717+ , testSession "extend single line import with type" $ template

718+ (T.unlines

719+ [ "module ModuleA where"

720+ , "type A = Double"

721+ ])

722+ (T.unlines

723+ [ "module ModuleB where"

724+ , "import ModuleA ()"

725+ , "b :: A"

726+ , "b = 0"

727+ ])

728+ (Range (Position 2 5) (Position 2 5))

729+ "Add A to the import list of ModuleA"

730+ (T.unlines

731+ [ "module ModuleB where"

732+ , "import ModuleA (A)"

733+ , "b :: A"

734+ , "b = 0"

735+ ])

736+ , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template

737+ (T.unlines

738+ [ "module ModuleA where"

739+ , "data A = Constructor"

740+ ])

741+ (T.unlines

742+ [ "module ModuleB where"

743+ , "import ModuleA (A)"

744+ , "b :: A"

745+ , "b = Constructor"

746+ ])

747+ (Range (Position 2 5) (Position 2 5))

748+ "Add Constructor to the import list of ModuleA"

749+ (T.unlines

750+ [ "module ModuleB where"

751+ , "import ModuleA (A(Constructor))"

752+ , "b :: A"

753+ , "b = Constructor"

754+ ])

755+ , testSession "extend single line qualified import with value" $ template

756+ (T.unlines

757+ [ "module ModuleA where"

758+ , "stuffA :: Double"

759+ , "stuffA = 0.00750"

760+ , "stuffB :: Integer"

761+ , "stuffB = 123"

762+ ])

763+ (T.unlines

764+ [ "module ModuleB where"

765+ , "import qualified ModuleA as A (stuffB)"

766+ , "main = print (A.stuffA, A.stuffB)"

767+ ])

768+ (Range (Position 3 17) (Position 3 18))

769+ "Add stuffA to the import list of ModuleA"

770+ (T.unlines

771+ [ "module ModuleB where"

772+ , "import qualified ModuleA as A (stuffA, stuffB)"

773+ , "main = print (A.stuffA, A.stuffB)"

774+ ])

775+ , testSession "extend multi line import with value" $ template

776+ (T.unlines

777+ [ "module ModuleA where"

778+ , "stuffA :: Double"

779+ , "stuffA = 0.00750"

780+ , "stuffB :: Integer"

781+ , "stuffB = 123"

782+ ])

783+ (T.unlines

784+ [ "module ModuleB where"

785+ , "import ModuleA (stuffB"

786+ , " )"

787+ , "main = print (stuffA, stuffB)"

788+ ])

789+ (Range (Position 3 17) (Position 3 18))

790+ "Add stuffA to the import list of ModuleA"

791+ (T.unlines

792+ [ "module ModuleB where"

793+ , "import ModuleA (stuffA, stuffB"

794+ , " )"

795+ , "main = print (stuffA, stuffB)"

796+ ])

797+ ]

798+ where

799+ template contentA contentB range expectedAction expectedContentB = do

800+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

801+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

802+ _ <- waitForDiagnostics

803+ CACodeAction action@CodeAction { _title = actionTitle } : _

804+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

805+ getCodeActions docB range

806+ liftIO $ expectedAction @=? actionTitle

807+ executeCodeAction action

808+ contentAfterAction <- documentContents docB

809+ liftIO $ expectedContentB @=? contentAfterAction

810+

811+fixConstructorImportTests :: TestTree

812+fixConstructorImportTests = testGroup "fix import actions"

813+ [ testSession "fix constructor import" $ template

814+ (T.unlines

815+ [ "module ModuleA where"

816+ , "data A = Constructor"

817+ ])

818+ (T.unlines

819+ [ "module ModuleB where"

820+ , "import ModuleA(Constructor)"

821+ ])

822+ (Range (Position 1 10) (Position 1 11))

823+ "Fix import of A(Constructor)"

824+ (T.unlines

825+ [ "module ModuleB where"

826+ , "import ModuleA(A(Constructor))"

827+ ])

828+ ]

829+ where

830+ template contentA contentB range expectedAction expectedContentB = do

831+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

832+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

833+ _diags <- waitForDiagnostics

834+ CACodeAction action@CodeAction { _title = actionTitle } : _

835+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

836+ getCodeActions docB range

837+ liftIO $ expectedAction @=? actionTitle

838+ executeCodeAction action

839+ contentAfterAction <- documentContents docB

840+ liftIO $ expectedContentB @=? contentAfterAction

841+

692842importRenameActionTests :: TestTree

693843importRenameActionTests = testGroup "import rename actions"

694844 [ testSession "Data.Mape -> Data.Map" $ check "Map"