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