git.iko.soy/ghcide
on 116a5ba help sign in
ghcide/src/Development/IDE/Plugin/CodeAction.hs
562 lines 25 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE CPP #-}
6#include "ghc-api-version.h"
8-- | Go to the definition of a variable.
9module Development.IDE.Plugin.CodeAction
10 (
11 plugin
13 -- * For haskell-language-server
14 , codeAction
15 , codeLens
16 , rulePackageExports
17 ) where
19import Language.Haskell.LSP.Types
20import Control.Monad (join)
21import Development.IDE.Plugin
22import Development.IDE.GHC.Compat
23import Development.IDE.Core.Rules
24import Development.IDE.Core.RuleTypes
25import Development.IDE.Core.Service
26import Development.IDE.Core.Shake
27import Development.IDE.GHC.Error
28import Development.IDE.GHC.Util
29import Development.IDE.LSP.Server
30import Development.IDE.Plugin.CodeAction.PositionIndexed
31import Development.IDE.Plugin.CodeAction.RuleTypes
32import Development.IDE.Plugin.CodeAction.Rules
33import Development.IDE.Types.Location
34import Development.IDE.Types.Options
35import Development.Shake (Rules)
36import qualified Data.HashMap.Strict as Map
37import qualified Language.Haskell.LSP.Core as LSP
38import Language.Haskell.LSP.VFS
39import Language.Haskell.LSP.Messages
40import qualified Data.Rope.UTF16 as Rope
41import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
42import Control.Monad.Trans.Maybe
43import Data.Char
44import Data.Maybe
45import Data.List.Extra
46import qualified Data.Text as T
47import Data.Tuple.Extra ((&&&))
48import HscTypes
49import Parser
50import Text.Regex.TDFA ((=~), (=~~))
51import Text.Regex.TDFA.Text()
52import Outputable (ppr, showSDocUnsafe)
53import DynFlags (xFlags, FlagSpec(..))
54import GHC.LanguageExtensions.Type (Extension)
56plugin :: Plugin c
57plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
59rules :: Rules ()
60rules = rulePackageExports
62-- | Generate code actions.
63codeAction
64 :: LSP.LspFuncs c
65 -> IdeState
66 -> TextDocumentIdentifier
67 -> Range
68 -> CodeActionContext
69 -> IO (Either ResponseError [CAResult])
70codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
71 -- disable logging as its quite verbose
72 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
73 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
74 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
75 mbFile = toNormalizedFilePath' <$> uriToFilePath uri
76 (ideOptions, parsedModule, join -> env) <- runAction state $
77 (,,) <$> getIdeOptions
78 <*> getParsedModule `traverse` mbFile
79 <*> use GhcSession `traverse` mbFile
80 pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
81 let dflags = hsc_dflags . hscEnv <$> env
82 pure $ Right
83 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
84 | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
85 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
86 ]
88-- | Generate code lenses.
89codeLens
90 :: LSP.LspFuncs c
91 -> IdeState
92 -> CodeLensParams
93 -> IO (Either ResponseError (List CodeLens))
94codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
95 fmap (Right . List) $ case uriToFilePath' uri of
96 Just (toNormalizedFilePath' -> filePath) -> do
97 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
98 diag <- getDiagnostics ideState
99 hDiag <- getHiddenDiagnostics ideState
100 pure
101 [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
102 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
103 , dFile == filePath
104 , (title, tedit) <- suggestSignature False dDiag
105 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
106 ]
107 Nothing -> pure []
109-- | Execute the "typesignature.add" command.
110executeAddSignatureCommand
111 :: LSP.LspFuncs c
112 -> IdeState
113 -> ExecuteCommandParams
114 -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
115executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
116 | _command == "typesignature.add"
117 , Just (List [edit]) <- _arguments
118 , Success wedit <- fromJSON edit
119 = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
120 | otherwise
121 = return (Right Null, Nothing)
123suggestAction
124 :: Maybe DynFlags
125 -> PackageExportsMap
126 -> IdeOptions
127 -> Maybe ParsedModule
128 -> Maybe T.Text
129 -> Diagnostic
130 -> [(T.Text, [TextEdit])]
131suggestAction dflags packageExports ideOptions parsedModule text diag = concat
132 [ suggestAddExtension diag
133 , suggestExtendImport dflags text diag
134 , suggestFillHole diag
135 , suggestFillTypeWildcard diag
136 , suggestFixConstructorImport text diag
137 , suggestModuleTypo diag
138 , suggestReplaceIdentifier text diag
139 , suggestSignature True diag
140 ] ++ concat
141 [ suggestNewDefinition ideOptions pm text diag
142 ++ suggestRemoveRedundantImport pm text diag
143 ++ suggestNewImport packageExports pm diag
144 | Just pm <- [parsedModule]]
147suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
148suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
149-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
150 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
151 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
152 , Just c <- contents
153 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
154 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
155 , not (null ranges')
156 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
158-- File.hs:16:1: warning:
159-- The import of `Data.List' is redundant
160-- except perhaps to import instances from `Data.List'
161-- To import instances alone, use: import Data.List()
162 | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
163 = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
164 | otherwise = []
166suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
167suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
168-- File.hs:52:41: error:
169-- * Variable not in scope:
170-- suggestAcion :: Maybe T.Text -> Range -> Range
171-- * Perhaps you meant ‘suggestAction’ (line 83)
172-- File.hs:94:37: error:
173-- Not in scope: ‘T.isPrfixOf’
174-- Perhaps you meant one of these:
175-- ‘T.isPrefixOf’ (imported from Data.Text),
176-- ‘T.isInfixOf’ (imported from Data.Text),
177-- ‘T.isSuffixOf’ (imported from Data.Text)
178-- Module ‘Data.Text’ does not export ‘isPrfixOf’.
179 | renameSuggestions@(_:_) <- extractRenamableTerms _message
180 = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
181 | otherwise = []
183suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
184suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}
185-- * Variable not in scope:
186-- suggestAcion :: Maybe T.Text -> Range -> Range
187 | Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
188 = newDefinitionAction ideOptions parsedModule _range name typ
189 | Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"
190 , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ
191 = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
192 | otherwise = []
193 where
194 message = unifySpaces _message
196newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]
197newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
198 | Range _ lastLineP : _ <-
199 [ srcSpanToRange l
200 | (L l _) <- hsmodDecls
201 , _start `isInsideSrcSpan` l]
202 , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
203 = [ ("Define " <> sig
204 , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]
205 )]
206 | otherwise = []
207 where
208 colon = if optNewColonConvention then " : " else " :: "
209 sig = name <> colon <> T.dropWhileEnd isSpace typ
210 ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
213suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
214suggestFillTypeWildcard Diagnostic{_range=_range,..}
215-- Foo.hs:3:8: error:
216-- * Found type wildcard `_' standing for `p -> p1 -> p'
218 | "Found type wildcard" `T.isInfixOf` _message
219 , " standing for " `T.isInfixOf` _message
220 , typeSignature <- extractWildCardTypeSignature _message
221 = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
222 | otherwise = []
224suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
225suggestAddExtension Diagnostic{_range=_range,..}
226-- File.hs:22:8: error:
227-- Illegal lambda-case (use -XLambdaCase)
228-- File.hs:22:6: error:
229-- Illegal view pattern: x -> foo
230-- Use ViewPatterns to enable view patterns
231-- File.hs:26:8: error:
232-- Illegal `..' in record pattern
233-- Use RecordWildCards to permit this
234-- File.hs:53:28: error:
235-- Illegal tuple section: use TupleSections
236-- File.hs:238:29: error:
237-- * Can't make a derived instance of `Data FSATrace':
238-- You need DeriveDataTypeable to derive an instance for this class
239-- * In the data declaration for `FSATrace'
240-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:
241-- * Illegal equational constraint a ~ ()
242-- (Use GADTs or TypeFamilies to permit this)
243-- * In the context: a ~ ()
244-- While checking an instance declaration
245-- In the instance declaration for `Unit (m a)'
246 | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
247 = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
248 | otherwise = []
250-- | All the GHC extensions
251ghcExtensions :: Map.HashMap T.Text Extension
252ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
254suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
255suggestModuleTypo Diagnostic{_range=_range,..}
256-- src/Development/IDE/Core/Compile.hs:58:1: error:
257-- Could not find module ‘Data.Cha’
258-- Perhaps you meant Data.Char (from base-4.12.0.0)
259 | "Could not find module" `T.isInfixOf` _message
260 , "Perhaps you meant" `T.isInfixOf` _message = let
261 findSuggestedModules = map (head . T.words) . drop 2 . T.lines
262 proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
263 in map proposeModule $ nubOrd $ findSuggestedModules _message
264 | otherwise = []
266suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
267suggestFillHole Diagnostic{_range=_range,..}
268-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
269-- * Found hole: _ :: Int -> String
270-- * In the expression: _
271-- In the expression: _ a
272-- In an equation for ‘foo’: foo a = _ a
273-- * Relevant bindings include
274-- a :: Int
275-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)
276-- foo :: Int -> String
277-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
278-- Valid hole fits include
279-- foo :: Int -> String
280-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
281-- show :: forall a. Show a => a -> String
282-- with show @Int
283-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
284-- (and originally defined in ‘GHC.Show’))
285-- mempty :: forall a. Monoid a => a
286-- with mempty @(Int -> String)
287-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
288-- (and originally defined in ‘GHC.Base’)) (lsp-ui)
290 | topOfHoleFitsMarker `T.isInfixOf` _message = let
291 findSuggestedHoleFits :: T.Text -> [T.Text]
292 findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
293 proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])
294 holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
295 dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
296 selectLinesWithFits = filter ("::" `T.isInfixOf`)
297 extractFitNames = map (T.strip . head . T.splitOn " :: ")
298 in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
300 | otherwise = []
302suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
303suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
304 | Just [binding, mod, srcspan] <-
305 matchRegex _message
306 "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
307 , Just c <- contents
308 , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier
309 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
310 [s] -> let x = srcSpanToRange s
311 in x{_end = (_end x){_character = succ (_character (_end x))}}
312 _ -> error "bug in srcspan parser"
313 importLine = textInRange range c
314 in [("Add " <> binding <> " to the import list of " <> mod
315 , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]
316 | otherwise = []
317suggestExtendImport Nothing _ _ = []
319suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
320suggestFixConstructorImport _ Diagnostic{_range=_range,..}
321 -- ‘Success’ is a data constructor of ‘Result’
322 -- To import it use
323 -- import Data.Aeson.Types( Result( Success ) )
324 -- or
325 -- import Data.Aeson.Types( Result(..) ) (lsp-ui)
326 | Just [constructor, typ] <-
327 matchRegex _message
328 "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
329 = let fixedImport = typ <> "(" <> constructor <> ")"
330 in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
331 | otherwise = []
333suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
334suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
335 | _message =~
336 ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
337 signature = removeInitialForAll
338 $ T.takeWhile (\x -> x/='*' && x/='•')
339 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
340 startOfLine = Position (_line _start) startCharacter
341 beforeLine = Range startOfLine startOfLine
342 title = if isQuickFix then "add signature: " <> signature else signature
343 action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
344 in [(title, [action])]
345 where removeInitialForAll :: T.Text -> T.Text
346 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
347 | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
348 | otherwise = nm <> ty
349 startCharacter
350 | "Polymorphic local binding" `T.isPrefixOf` _message
351 = _character _start
352 | otherwise
353 = 0
355suggestSignature _ _ = []
357-------------------------------------------------------------------------------------------------
359suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
360suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
361 | msg <- unifySpaces _message
362 , Just name <- extractNotInScopeName msg
363 , Just insertLine <- case hsmodImports of
364 [] -> case srcSpanStart $ getLoc (head hsmodDecls) of
365 RealSrcLoc s -> Just $ srcLocLine s - 1
366 _ -> Nothing
367 _ -> case srcSpanEnd $ getLoc (last hsmodImports) of
368 RealSrcLoc s -> Just $ srcLocLine s
369 _ -> Nothing
370 , insertPos <- Position insertLine 0
371 , extendImportSuggestions <- matchRegex msg
372 "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
373 = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
374 | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions
375 ]
376suggestNewImport _ _ _ = []
378constructNewImportSuggestions
379 :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]
380constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd
381 [ renderNewImport identInfo m
382 | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap
383 , canUseIdent thingMissing identInfo
384 , m `notElem` fromMaybe [] notTheseModules
385 ]
386 where
387 renderNewImport identInfo m
388 | Just q <- qual = "import qualified " <> m <> " as " <> q
389 | otherwise = "import " <> m <> " (" <> importWhat identInfo <> ")"
391 (qual, name) = case T.splitOn "." (notInScope thingMissing) of
392 [n] -> (Nothing, n)
393 segments -> (Just (T.concat $ init segments), last segments)
394 importWhat IdentInfo {parent, rendered}
395 | Just p <- parent = p <> "(" <> rendered <> ")"
396 | otherwise = rendered
398canUseIdent :: NotInScope -> IdentInfo -> Bool
399canUseIdent NotInScopeDataConstructor{} = isDatacon
400canUseIdent _ = const True
402data NotInScope
403 = NotInScopeDataConstructor T.Text
404 | NotInScopeTypeConstructorOrClass T.Text
405 | NotInScopeThing T.Text
406 deriving Show
408notInScope :: NotInScope -> T.Text
409notInScope (NotInScopeDataConstructor t) = t
410notInScope (NotInScopeTypeConstructorOrClass t) = t
411notInScope (NotInScopeThing t) = t
413extractNotInScopeName :: T.Text -> Maybe NotInScope
414extractNotInScopeName x
415 | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"
416 = Just $ NotInScopeDataConstructor name
417 | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"
418 = Just $ NotInScopeDataConstructor name
419 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
420 = Just $ NotInScopeTypeConstructorOrClass name
421 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"
422 = Just $ NotInScopeThing name
423 | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"
424 = Just $ NotInScopeThing name
425 | otherwise
426 = Nothing
428-------------------------------------------------------------------------------------------------
430topOfHoleFitsMarker :: T.Text
431topOfHoleFitsMarker =
432#if MIN_GHC_API_VERSION(8,6,0)
433 "Valid hole fits include"
434#else
435 "Valid substitutions include"
436#endif
438mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
439mkRenameEdit contents range name =
440 if maybeIsInfixFunction == Just True
441 then TextEdit range ("`" <> name <> "`")
442 else TextEdit range name
443 where
444 maybeIsInfixFunction = do
445 curr <- textInRange range <$> contents
446 pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
448extractWildCardTypeSignature :: T.Text -> T.Text
449extractWildCardTypeSignature =
450 -- inferring when parens are actually needed around the type signature would
451 -- require understanding both the precedence of the context of the _ and of
452 -- the signature itself. Inserting them unconditionally is ugly but safe.
453 ("(" `T.append`) . (`T.append` ")") .
454 T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
455 snd . T.breakOnEnd "standing for "
457extractRenamableTerms :: T.Text -> [T.Text]
458extractRenamableTerms msg
459 -- Account for both "Variable not in scope" and "Not in scope"
460 | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg
461 | otherwise = []
462 where
463 extractSuggestions = map getEnclosed
464 . concatMap singleSuggestions
465 . filter isKnownSymbol
466 . T.lines
467 singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited
468 isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t
469 getEnclosed = T.dropWhile (== '‘')
470 . T.dropWhileEnd (== '’')
471 . T.dropAround (\c -> c /= '‘' && c /= '’')
473-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace
474-- between the end of the range and the next newline), extend the range to take up the whole line.
475extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range
476extendToWholeLineIfPossible contents range@Range{..} =
477 let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents
478 extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
479 in if extend then Range _start (Position (_line _end + 1) 0) else range
481splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
482splitTextAtPosition (Position row col) x
483 | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
484 , (preCol, postCol) <- T.splitAt col mid
485 = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
486 | otherwise = (x, T.empty)
488-- | Returns [start .. end[
489textInRange :: Range -> T.Text -> T.Text
490textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
491 case compare startRow endRow of
492 LT ->
493 let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
494 (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
495 [] -> ("", [])
496 firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
497 maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
498 in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
499 EQ ->
500 let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
501 in T.take (endCol - startCol) (T.drop startCol line)
502 GT -> ""
503 where
504 linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
506-- | Returns the ranges for a binding in an import declaration
507rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
508rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
509 concatMap (map srcSpanToRange . rangesForBinding' b') lies
510 where
511 b' = wrapOperatorInParens (unqualify b)
513 wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
515 unqualify x = snd $ breakOnEnd "." x
517rangesForBinding _ _ = []
519rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
520rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
521rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
522rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]
523rangesForBinding' b (L l (IEThingWith thing _ inners labels))
524 | showSDocUnsafe (ppr thing) == b = [l]
525 | otherwise =
526 [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
527 [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
528rangesForBinding' _ _ = []
530-- | Extends an import list with a new binding.
531-- Assumes an import statement of the form:
532-- import (qualified) A (..) ..
533-- Places the new binding first, preserving whitespace.
534-- Copes with multi-line import lists
535addBindingToImportList :: T.Text -> T.Text -> T.Text
536addBindingToImportList binding importLine = case T.breakOn "(" importLine of
537 (pre, T.uncons -> Just (_, rest)) ->
538 case T.uncons (T.dropWhile isSpace rest) of
539 Just (')', _) -> T.concat [pre, "(", binding, rest]
540 _ -> T.concat [pre, "(", binding, ", ", rest]
541 _ ->
542 error
543 $ "importLine does not have the expected structure: "
544 <> T.unpack importLine
546-- | Returns Just (the submatches) for the first capture, or Nothing.
547matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
548matchRegex message regex = case unifySpaces message =~~ regex of
549 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
550 Nothing -> Nothing
552setHandlersCodeLens :: PartialHandlers c
553setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
554 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
555 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
556 }
558filterNewlines :: T.Text -> T.Text
559filterNewlines = T.concat . T.lines
561unifySpaces :: T.Text -> T.Text
562unifySpaces = T.unwords . T.words