1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE DuplicateRecordFields #-}
6#include "ghc-api-version.h"
8-- | Go to the definition of a variable.
9module Development.IDE.LSP.CodeAction
10 ( setHandlersCodeAction
14import Language.Haskell.LSP.Types
15import Control.Monad (join)
16import Development.IDE.GHC.Compat
17import Development.IDE.Core.Rules
18import Development.IDE.Core.RuleTypes
19import Development.IDE.Core.Shake
20import Development.IDE.GHC.Error
21import Development.IDE.LSP.Server
22import Development.IDE.Types.Location
23import qualified Data.HashMap.Strict as Map
24import qualified Data.HashSet as Set
25import qualified Language.Haskell.LSP.Core as LSP
26import Language.Haskell.LSP.VFS
27import Language.Haskell.LSP.Messages
28import qualified Data.Rope.UTF16 as Rope
29import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
30import Control.Monad.Trans.Maybe
34import qualified Data.Text as T
35import Text.Regex.TDFA ((=~), (=~~))
36import Text.Regex.TDFA.Text()
37import Outputable (ppr, showSDocUnsafe)
39-- | Generate code actions.
45codeAction lsp state CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do
46 -- disable logging as its quite verbose
47 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
48 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
49 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
50 parsedModule <- (runAction state . getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
52 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
53 | x <- xs, (title, tedit) <- suggestAction ( join parsedModule ) text x
54 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
57-- | Generate code lenses.
63codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
64 case uriToFilePath' uri of
65 Just (toNormalizedFilePath -> filePath) -> do
66 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
67 diag <- getDiagnostics ideState
68 hDiag <- getHiddenDiagnostics ideState
70 [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
71 | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag
73 , (title, tedit) <- suggestSignature False dDiag
74 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
76 Nothing -> pure $ List []
78-- | Execute the "typesignature.add" command.
79executeAddSignatureCommand
82 -> ExecuteCommandParams
83 -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
84executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
85 | _command == "typesignature.add"
86 , Just (List [edit]) <- _arguments
87 , Success wedit <- fromJSON edit
88 = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
90 = return (Null, Nothing)
92suggestAction :: Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
93suggestAction parsedModule text diag = concat
94 [ suggestAddExtension diag
95 , suggestExtendImport text diag
96 , suggestFillHole diag
97 , suggestFillTypeWildcard diag
98 , suggestFixConstructorImport text diag
99 , suggestModuleTypo diag
100 , suggestReplaceIdentifier text diag
101 , suggestSignature True diag
103 [ suggestRemoveRedundantImport pm text diag | Just pm <- [parsedModule]]
106suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
107suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}
108-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
109 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
110 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
112 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
113 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
114 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
116-- File.hs:16:1: warning:
117-- The import of `Data.List' is redundant
118-- except perhaps to import instances from `Data.List'
119-- To import instances alone, use: import Data.List()
120 | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
121 = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
124suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
125suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}
126-- File.hs:52:41: error:
127-- * Variable not in scope:
128-- suggestAcion :: Maybe T.Text -> Range -> Range
129-- * Perhaps you meant ‘suggestAction’ (line 83)
130-- File.hs:94:37: error:
131-- Not in scope: ‘T.isPrfixOf’
132-- Perhaps you meant one of these:
133-- ‘T.isPrefixOf’ (imported from Data.Text),
134-- ‘T.isInfixOf’ (imported from Data.Text),
135-- ‘T.isSuffixOf’ (imported from Data.Text)
136-- Module ‘Data.Text’ does not export ‘isPrfixOf’.
137 | renameSuggestions@(_:_) <- extractRenamableTerms _message
138 = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
141suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
142suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
144-- * Found type wildcard `_' standing for `p -> p1 -> p'
146 | "Found type wildcard" `T.isInfixOf` _message
147 , " standing for " `T.isInfixOf` _message
148 , typeSignature <- extractWildCardTypeSignature _message
149 = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
152suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
153suggestAddExtension Diagnostic{_range=_range@Range{..},..}
154-- File.hs:22:8: error:
155-- Illegal lambda-case (use -XLambdaCase)
156-- File.hs:22:6: error:
157-- Illegal view pattern: x -> foo
158-- Use ViewPatterns to enable view patterns
159-- File.hs:26:8: error:
160-- Illegal `..' in record pattern
161-- Use RecordWildCards to permit this
162-- File.hs:53:28: error:
163-- Illegal tuple section: use TupleSections
164-- File.hs:238:29: error:
165-- * Can't make a derived instance of `Data FSATrace':
166-- You need DeriveDataTypeable to derive an instance for this class
167-- * In the data declaration for `FSATrace'
168-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:
169-- * Illegal equational constraint a ~ ()
170-- (Use GADTs or TypeFamilies to permit this)
171-- * In the context: a ~ ()
172-- While checking an instance declaration
173-- In the instance declaration for `Unit (m a)'
174 | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
175 = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
178suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
179suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
180-- src/Development/IDE/Core/Compile.hs:58:1: error:
181-- Could not find module ‘Data.Cha’
182-- Perhaps you meant Data.Char (from base-4.12.0.0)
183 | "Could not find module" `T.isInfixOf` _message
184 , "Perhaps you meant" `T.isInfixOf` _message = let
185 findSuggestedModules = map (head . T.words) . drop 2 . T.lines
186 proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
187 in map proposeModule $ nubOrd $ findSuggestedModules _message
190suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
191suggestFillHole Diagnostic{_range=_range@Range{..},..}
192-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
193-- * Found hole: _ :: Int -> String
194-- * In the expression: _
195-- In the expression: _ a
196-- In an equation for ‘foo’: foo a = _ a
197-- * Relevant bindings include
199-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)
200-- foo :: Int -> String
201-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
202-- Valid hole fits include
203-- foo :: Int -> String
204-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
205-- show :: forall a. Show a => a -> String
207-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
208-- (and originally defined in ‘GHC.Show’))
209-- mempty :: forall a. Monoid a => a
210-- with mempty @(Int -> String)
211-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
212-- (and originally defined in ‘GHC.Base’)) (lsp-ui)
214 | topOfHoleFitsMarker `T.isInfixOf` _message = let
215 findSuggestedHoleFits :: T.Text -> [T.Text]
216 findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
217 proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])
218 holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
219 dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
220 selectLinesWithFits = filter ("::" `T.isInfixOf`)
221 extractFitNames = map (T.strip . head . T.splitOn " :: ")
222 in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
226suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
227suggestExtendImport contents Diagnostic{_range=_range,..}
228 | Just [binding, mod, srcspan] <-
230 "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
232 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
233 [s] -> let x = srcSpanToRange s
234 in x{_end = (_end x){_character = succ (_character (_end x))}}
235 _ -> error "bug in srcspan parser"
236 importLine = textInRange range c
237 in [("Add " <> binding <> " to the import list of " <> mod
238 , [TextEdit range (addBindingToImportList binding importLine)])]
241suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
242suggestFixConstructorImport _ Diagnostic{_range=_range,..}
243 -- ‘Success’ is a data constructor of ‘Result’
245 -- import Data.Aeson.Types( Result( Success ) )
247 -- import Data.Aeson.Types( Result(..) ) (lsp-ui)
248 | Just [constructor, typ] <-
250 "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
251 = let fixedImport = typ <> "(" <> constructor <> ")"
252 in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
255suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
256suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
257 | "Top-level binding with no type signature" `T.isInfixOf` _message = let
258 filterNewlines = T.concat . T.lines
259 unifySpaces = T.unwords . T.words
260 signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
261 startOfLine = Position (_line _start) 0
262 beforeLine = Range startOfLine startOfLine
263 title = if isQuickFix then "add signature: " <> signature else signature
264 action = TextEdit beforeLine $ signature <> "\n"
265 in [(title, [action])]
266suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
267 | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let
268 filterNewlines = T.concat . T.lines
269 unifySpaces = T.unwords . T.words
270 signature = removeInitialForAll
271 $ T.takeWhile (\x -> x/='*' && x/='•')
272 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
273 startOfLine = Position (_line _start) (_character _start)
274 beforeLine = Range startOfLine startOfLine
275 title = if isQuickFix then "add signature: " <> signature else signature
276 action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "
277 in [(title, [action])]
278 where removeInitialForAll :: T.Text -> T.Text
279 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
280 | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
281 | otherwise = nm <> ty
282suggestSignature _ _ = []
284topOfHoleFitsMarker :: T.Text
286#if MIN_GHC_API_VERSION(8,6,0)
287 "Valid hole fits include"
289 "Valid substitutions include"
292mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
293mkRenameEdit contents range name =
294 if fromMaybe False maybeIsInfixFunction
295 then TextEdit range ("`" <> name <> "`")
296 else TextEdit range name
298 maybeIsInfixFunction = do
299 curr <- textInRange range <$> contents
300 pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
302extractWildCardTypeSignature :: T.Text -> T.Text
303extractWildCardTypeSignature =
304 -- inferring when parens are actually needed around the type signature would
305 -- require understanding both the precedence of the context of the _ and of
306 -- the signature itself. Inserting them unconditionally is ugly but safe.
307 ("(" `T.append`) . (`T.append` ")") .
308 T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
309 snd . T.breakOnEnd "standing for "
311extractRenamableTerms :: T.Text -> [T.Text]
312extractRenamableTerms msg
313 -- Account for both "Variable not in scope" and "Not in scope"
314 | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg
317 extractSuggestions = map getEnclosed
318 . concatMap singleSuggestions
319 . filter isKnownSymbol
321 singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited
322 isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t
323 getEnclosed = T.dropWhile (== '‘')
324 . T.dropWhileEnd (== '’')
325 . T.dropAround (\c -> c /= '‘' && c /= '’')
327-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace
328-- between the end of the range and the next newline), extend the range to take up the whole line.
329extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range
330extendToWholeLineIfPossible contents range@Range{..} =
331 let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents
332 extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
333 in if extend then Range _start (Position (_line _end + 1) 0) else range
335-- | All the GHC extensions
336ghcExtensions :: Set.HashSet T.Text
337ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions
339splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
340splitTextAtPosition (Position row col) x
341 | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
342 , (preCol, postCol) <- T.splitAt col mid
343 = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
344 | otherwise = (x, T.empty)
346-- | Returns [start .. end[
347textInRange :: Range -> T.Text -> T.Text
348textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
349 case compare startRow endRow of
351 let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
352 (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
354 firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
355 maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
356 in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
358 let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
359 in T.take (endCol - startCol) (T.drop startCol line)
362 linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
364-- | Returns the ranges for a binding in an import declaration
365rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
366rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
367 concatMap (map srcSpanToRange . rangesForBinding' b') lies
369 b' = wrapOperatorInParens (unqualify b)
371 wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
373 unqualify x = snd $ breakOnEnd "." x
375rangesForBinding _ _ = []
377rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
378rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
379rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
380rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]
381rangesForBinding' b (L l (IEThingWith thing _ inners labels))
382 | showSDocUnsafe (ppr thing) == b = [l]
384 [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
385 [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
386rangesForBinding' _ _ = []
388-- | Extends an import list with a new binding.
389-- Assumes an import statement of the form:
390-- import (qualified) A (..) ..
391-- Places the new binding first, preserving whitespace.
392-- Copes with multi-line import lists
393addBindingToImportList :: T.Text -> T.Text -> T.Text
394addBindingToImportList binding importLine = case T.breakOn "(" importLine of
395 (pre, T.uncons -> Just (_, rest)) ->
396 case T.uncons (T.dropWhile isSpace rest) of
397 Just (')', _) -> T.concat [pre, "(", binding, rest]
398 _ -> T.concat [pre, "(", binding, ", ", rest]
401 $ "importLine does not have the expected structure: "
402 <> T.unpack importLine
404-- | Returns Just (the submatches) for the first capture, or Nothing.
405matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
406matchRegex message regex = case T.unwords (T.words message) =~~ regex of
407 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
410setHandlersCodeAction :: PartialHandlers
411setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
412 LSP.codeActionHandler = withResponse RspCodeAction codeAction
415setHandlersCodeLens :: PartialHandlers
416setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
417 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
418 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
421--------------------------------------------------------------------------------
423type PositionIndexedString = [(Position, Char)]
425indexedByPosition :: String -> PositionIndexedString
426indexedByPosition = unfoldr f . (Position 0 0,) where
428 f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))
429 f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))
431-- | Returns a tuple (before, contents, after)
432unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)
433unconsRange Range {..} indexedString = (before, mid, after)
435 (before, rest) = span ((/= _start) . fst) indexedString
436 (mid, after) = span ((/= _end) . fst) rest
438stripRange :: Range -> PositionIndexedString -> PositionIndexedString
439stripRange r s = case unconsRange r s of
442extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
443extendAllToIncludeCommaIfPossible _ [] = []
444extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr
446 r' = case extendToIncludeCommaIfPossible indexedString r of
449 indexedString' = stripRange r' indexedString
451-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas
452extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
453extendToIncludeCommaIfPossible indexedString range =
454 -- a, |b|, c ===> a|, b|, c
455 [ range{_start = start'}
456 | (start', ',') : _ <- [before']
459 -- a, |b|, c ===> a, |b, |c
461 | (_, ',') : rest <- [after']
462 , let (end', _) : _ = dropWhile (isSpace . snd) rest
465 (before, _, after) = unconsRange range indexedString
466 after' = dropWhile (isSpace . snd) after
467 before' = dropWhile (isSpace . snd) (reverse before)
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list