1-- Copyright (c) 2019 The DAML Authors. All rights reserved. 2-- SPDX-License-Identifier: Apache-2.0 3 4{-# LANGUAGE CPP #-} 5{-# LANGUAGE DuplicateRecordFields #-} 6 7-- | Go to the definition of a variable. 8 9module Development.IDE.Plugin.CodeAction 10 ( 11 iePluginDescriptor, 12 typeSigsPluginDescriptor, 13 bindingsPluginDescriptor, 14 fillHolePluginDescriptor, 15 newImport, 16 newImportToEdit 17 -- * For testing 18 , matchRegExMultipleImports 19 ) where 20 21import Bag (bagToList, 22 isEmptyBag) 23import Control.Applicative ((<|>)) 24import Control.Arrow (second, 25 (>>>)) 26import Control.Monad (guard, join) 27import Control.Monad.IO.Class 28import Data.Char 29import qualified Data.DList as DL 30import Data.Function 31import Data.Functor 32import qualified Data.HashMap.Strict as Map 33import qualified Data.HashSet as Set 34import Data.List.Extra 35import Data.List.NonEmpty (NonEmpty ((:|))) 36import qualified Data.List.NonEmpty as NE 37import qualified Data.Map as M 38import Data.Maybe 39import qualified Data.Rope.UTF16 as Rope 40import qualified Data.Set as S 41import qualified Data.Text as T 42import Data.Tuple.Extra (fst3) 43import Development.IDE.Core.RuleTypes 44import Development.IDE.Core.Rules 45import Development.IDE.Core.Service 46import Development.IDE.GHC.Compat 47import Development.IDE.GHC.Error 48import Development.IDE.GHC.Util (prettyPrint, 49 printRdrName, 50 unsafePrintSDoc) 51import Development.IDE.Plugin.CodeAction.Args 52import Development.IDE.Plugin.CodeAction.ExactPrint 53import Development.IDE.Plugin.CodeAction.PositionIndexed 54import Development.IDE.Plugin.TypeLenses (suggestSignature) 55import Development.IDE.Spans.Common 56import Development.IDE.Types.Exports 57import Development.IDE.Types.Location 58import Development.IDE.Types.Options 59import qualified GHC.LanguageExtensions as Lang 60import HscTypes (ImportedModsVal (..), 61 importedByUser) 62import Ide.PluginUtils (subRange) 63import Ide.Types 64import qualified Language.LSP.Server as LSP 65import Language.LSP.Types (CodeAction (..), 66 CodeActionContext (CodeActionContext, _diagnostics), 67 CodeActionKind (CodeActionQuickFix, CodeActionUnknown), 68 CodeActionParams (CodeActionParams), 69 Command, 70 Diagnostic (..), 71 List (..), 72 ResponseError, 73 SMethod (STextDocumentCodeAction), 74 TextDocumentIdentifier (TextDocumentIdentifier), 75 TextEdit (TextEdit), 76 WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), 77 type (|?) (InR), 78 uriToFilePath) 79import Language.LSP.VFS 80import Module (moduleEnvElts) 81import OccName 82import Outputable (Outputable, 83 ppr, 84 showSDoc, 85 showSDocUnsafe) 86import RdrName (GlobalRdrElt (..), 87 lookupGlobalRdrEnv) 88import SrcLoc (realSrcSpanEnd, 89 realSrcSpanStart) 90import TcRnTypes (ImportAvails (..), 91 TcGblEnv (..)) 92import Text.Regex.TDFA (mrAfter, 93 (=~), (=~~)) 94 95------------------------------------------------------------------------------------------------- 96 97-- | Generate code actions. 98codeAction 99 :: IdeState 100 -> PluginId 101 -> CodeActionParams 102 -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) 103codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do 104 contents <- LSP.getVirtualFile $ toNormalizedUri uri 105 liftIO $ do 106 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents 107 mbFile = toNormalizedFilePath' <$> uriToFilePath uri 108 diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state 109 (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile 110 let 111 actions = caRemoveRedundantImports parsedModule text diag xs uri 112 <> caRemoveInvalidExports parsedModule text diag xs uri 113 pure $ Right $ List actions 114 115------------------------------------------------------------------------------------------------- 116 117iePluginDescriptor :: PluginId -> PluginDescriptor IdeState 118iePluginDescriptor plId = 119 let old = 120 mkGhcideCAsPlugin [ 121 wrap suggestExtendImport 122 , wrap suggestImportDisambiguation 123 , wrap suggestNewOrExtendImportForClassMethod 124 , wrap suggestNewImport 125 , wrap suggestModuleTypo 126 , wrap suggestFixConstructorImport 127 , wrap suggestHideShadow 128 , wrap suggestExportUnusedTopBinding 129 ] 130 plId 131 in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction} 132 133typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState 134typeSigsPluginDescriptor = 135 mkGhcideCAsPlugin [ 136 wrap $ suggestSignature True 137 , wrap suggestFillTypeWildcard 138 , wrap removeRedundantConstraints 139 , wrap suggestAddTypeAnnotationToSatisfyContraints 140 , wrap suggestConstraint 141 ] 142 143bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState 144bindingsPluginDescriptor = 145 mkGhcideCAsPlugin [ 146 wrap suggestReplaceIdentifier 147 , wrap suggestImplicitParameter 148 , wrap suggestNewDefinition 149 , wrap suggestDeleteUnusedBinding 150 ] 151 152fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState 153fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole 154 155------------------------------------------------------------------------------------------------- 156 157findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) 158findSigOfDecl pred decls = 159 listToMaybe 160 [ sig 161 | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls, 162 any (pred . unLoc) idsSig 163 ] 164 165findSigOfDeclRanged :: Range -> [LHsDecl p] -> Maybe (Sig p) 166findSigOfDeclRanged range decls = do 167 dec <- findDeclContainingLoc (_start range) decls 168 case dec of 169 L _ (SigD _ sig@TypeSig {}) -> Just sig 170 L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind 171 _ -> Nothing 172 173findSigOfBind :: Range -> HsBind p -> Maybe (Sig p) 174findSigOfBind range bind = 175 case bind of 176 FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) 177 _ -> Nothing 178 where 179 findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) 180 findSigOfLMatch ls = do 181 match <- findDeclContainingLoc (_start range) ls 182 findSigOfGRHSs (m_grhss (unLoc match)) 183 184 findSigOfGRHSs :: GRHSs p (LHsExpr p) -> Maybe (Sig p) 185 findSigOfGRHSs grhs = do 186 if _start range `isInsideSrcSpan` (getLoc $ grhssLocalBinds grhs) 187 then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause 188 else do 189 grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) 190 case unLoc grhs of 191 GRHS _ _ bd -> findSigOfExpr (unLoc bd) 192 _ -> Nothing 193 194 findSigOfExpr :: HsExpr p -> Maybe (Sig p) 195 findSigOfExpr = go 196 where 197 go (HsLet _ binds _) = findSigOfBinds range (unLoc binds) 198 go (HsDo _ _ stmts) = do 199 stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) 200 case stmtlr of 201 LetStmt _ lhsLocalBindsLR -> findSigOfBinds range $ unLoc lhsLocalBindsLR 202 _ -> Nothing 203 go _ = Nothing 204 205findSigOfBinds :: Range -> HsLocalBinds p -> Maybe (Sig p) 206findSigOfBinds range = go 207 where 208 go (HsValBinds _ (ValBinds _ binds lsigs)) = 209 case unLoc <$> findDeclContainingLoc (_start range) lsigs of 210 Just sig' -> Just sig' 211 Nothing -> do 212 lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds) 213 findSigOfBind range (unLoc lHsBindLR) 214 go _ = Nothing 215 216findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) 217findInstanceHead df instanceHead decls = 218 listToMaybe 219 [ hsib_body 220 | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls, 221 showSDoc df (ppr hsib_body) == instanceHead 222 ] 223 224findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) 225findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) 226 227 228-- Single: 229-- This binding for ‘mod’ shadows the existing binding 230-- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 231-- (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing) 232-- Multi: 233--This binding for ‘pack’ shadows the existing bindings 234-- imported from ‘Data.ByteString’ at B.hs:6:1-22 235-- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 236-- imported from ‘Data.Text’ at B.hs:7:1-16 237suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] 238suggestHideShadow ps@(L _ HsModule {hsmodImports}) fileContents mTcM mHar Diagnostic {_message, _range} 239 | Just [identifier, modName, s] <- 240 matchRegexUnifySpaces 241 _message 242 "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" = 243 suggests identifier modName s 244 | Just [identifier] <- 245 matchRegexUnifySpaces 246 _message 247 "This binding for ‘([^`]+)’ shadows the existing bindings", 248 Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)", 249 mods <- [(modName, s) | [_, modName, s] <- matched], 250 result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier), 251 hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) = 252 result <> [hideAll] 253 | otherwise = [] 254 where 255 suggests identifier modName s 256 | Just tcM <- mTcM, 257 Just har <- mHar, 258 [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], 259 isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'), 260 mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, 261 title <- "Hide " <> identifier <> " from " <> modName = 262 if modName == "Prelude" && null mDecl 263 then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents 264 else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl 265 | otherwise = [] 266 267findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs) 268findImportDeclByModuleName decls modName = flip find decls $ \case 269 (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName) 270 _ -> error "impossible" 271 272isTheSameLine :: SrcSpan -> SrcSpan -> Bool 273isTheSameLine s1 s2 274 | Just sl1 <- getStartLine s1, 275 Just sl2 <- getStartLine s2 = 276 sl1 == sl2 277 | otherwise = False 278 where 279 getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x 280 281isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool 282isUnusedImportedId 283 TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}} 284 HAR {refMap} 285 identifier 286 modName 287 importSpan 288 | occ <- mkVarOcc identifier, 289 impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods, 290 Just rdrEnv <- 291 listToMaybe 292 [ imv_all_exports 293 | ImportedModsVal {..} <- impModsVals, 294 imv_name == mkModuleName modName, 295 isTheSameLine imv_span importSpan 296 ], 297 [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ, 298 importedIdentifier <- Right gre_name, 299 refs <- M.lookup importedIdentifier refMap = 300 maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs 301 | otherwise = False 302 303suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] 304suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} 305-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant 306 | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" 307 , Just (L _ impDecl) <- find (\(L l _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports 308 , Just c <- contents 309 , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) 310 , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) 311 , not (null ranges') 312 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] 313 314-- File.hs:16:1: warning: 315-- The import of `Data.List' is redundant 316-- except perhaps to import instances from `Data.List' 317-- To import instances alone, use: import Data.List() 318 | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String) 319 = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] 320 | otherwise = [] 321 322caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] 323caRemoveRedundantImports m contents digs ctxDigs uri 324 | Just pm <- m, 325 r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs, 326 allEdits <- [ e | (_, (_, edits)) <- r, e <- edits], 327 caRemoveAll <- removeAll allEdits, 328 ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs], 329 not $ null ctxEdits, 330 caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits 331 = caRemoveCtx ++ [caRemoveAll] 332 | otherwise = [] 333 where 334 removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where 335 _changes = Just $ Map.singleton uri $ List tedit 336 _documentChanges = Nothing 337 _changeAnnotations = Nothing 338 removeAll tedit = InR $ CodeAction{..} where 339 _changes = Just $ Map.singleton uri $ List tedit 340 _title = "Remove all redundant imports" 341 _kind = Just CodeActionQuickFix 342 _diagnostics = Nothing 343 _documentChanges = Nothing 344 _edit = Just WorkspaceEdit{..} 345 _isPreferred = Nothing 346 _command = Nothing 347 _disabled = Nothing 348 _xdata = Nothing 349 _changeAnnotations = Nothing 350 351caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] 352caRemoveInvalidExports m contents digs ctxDigs uri 353 | Just pm <- m, 354 Just txt <- contents, 355 txt' <- indexedByPosition $ T.unpack txt, 356 r <- mapMaybe (groupDiag pm) digs, 357 r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r, 358 caRemoveCtx <- mapMaybe removeSingle r', 359 allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges], 360 allRanges' <- extend txt' allRanges, 361 Just caRemoveAll <- removeAll allRanges', 362 ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs], 363 not $ null ctxEdits 364 = caRemoveCtx ++ [caRemoveAll] 365 | otherwise = [] 366 where 367 extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges 368 369 groupDiag pm dig 370 | Just (title, ranges) <- suggestRemoveRedundantExport pm dig 371 = Just (title, dig, ranges) 372 | otherwise = Nothing 373 374 removeSingle (_, _, []) = Nothing 375 removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where 376 tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges 377 _changes = Just $ Map.singleton uri $ List tedit 378 _title = title 379 _kind = Just CodeActionQuickFix 380 _diagnostics = Just $ List [diagnostic] 381 _documentChanges = Nothing 382 _edit = Just WorkspaceEdit{..} 383 _command = Nothing 384 _isPreferred = Nothing 385 _disabled = Nothing 386 _xdata = Nothing 387 _changeAnnotations = Nothing 388 removeAll [] = Nothing 389 removeAll ranges = Just $ InR $ CodeAction{..} where 390 tedit = concatMap (\r -> [TextEdit r ""]) ranges 391 _changes = Just $ Map.singleton uri $ List tedit 392 _title = "Remove all redundant exports" 393 _kind = Just CodeActionQuickFix 394 _diagnostics = Nothing 395 _documentChanges = Nothing 396 _edit = Just WorkspaceEdit{..} 397 _command = Nothing 398 _isPreferred = Nothing 399 _disabled = Nothing 400 _xdata = Nothing 401 _changeAnnotations = Nothing 402 403suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) 404suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} 405 | msg <- unifySpaces _message 406 , Just export <- hsmodExports 407 , Just exportRange <- getLocatedRange export 408 , exports <- unLoc export 409 , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) 410 <|> (,[_range]) <$> matchExportItem msg 411 <|> (,[_range]) <$> matchDupExport msg 412 , subRange _range exportRange 413 = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges) 414 where 415 matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’" 416 matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list" 417 getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of 418 [] -> (txt, [_range]) 419 ranges -> (txt, ranges) 420suggestRemoveRedundantExport _ _ = Nothing 421 422suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] 423suggestDeleteUnusedBinding 424 ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} 425 contents 426 Diagnostic{_range=_range,..} 427-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’ 428 | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" 429 , Just indexedContent <- indexedByPosition . T.unpack <$> contents 430 = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name) 431 in ([("Delete ‘" <> name <> "’", edits) | not (null edits)]) 432 | otherwise = [] 433 where 434 relatedRanges indexedContent name = 435 concatMap (findRelatedSpans indexedContent name) hsmodDecls 436 toRange = realSrcSpanToRange 437 extendForSpaces = extendToIncludePreviousNewlineIfPossible 438 439 findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range] 440 findRelatedSpans 441 indexedContent 442 name 443 (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = 444 case lname of 445 (L nLoc _name) | isTheBinding nLoc -> 446 let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig 447 findSig _ = [] 448 in 449 extendForSpaces indexedContent (toRange l) : 450 concatMap findSig hsmodDecls 451 _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches 452 findRelatedSpans _ _ _ = [] 453 454 extractNameAndMatchesFromFunBind 455 :: HsBind GhcPs 456 -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)]) 457 extractNameAndMatchesFromFunBind 458 FunBind 459 { fun_id=lname 460 , fun_matches=MG {mg_alts=L _ matches} 461 } = Just (lname, matches) 462 extractNameAndMatchesFromFunBind _ = Nothing 463 464 findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range] 465 findRelatedSigSpan indexedContent name l sig = 466 let maybeSpan = findRelatedSigSpan1 name sig 467 in case maybeSpan of 468 Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int 469 Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused 470 _ -> [] 471 472 -- Second of the tuple means there is only one match 473 findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool) 474 findRelatedSigSpan1 name (TypeSig _ lnames _) = 475 let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames 476 in case maybeIdx of 477 Nothing -> Nothing 478 Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True) 479 Just idx -> 480 let targetLname = getLoc $ lnames !! idx 481 startLoc = srcSpanStart targetLname 482 endLoc = srcSpanEnd targetLname 483 startLoc' = if idx == 0 484 then startLoc 485 else srcSpanEnd . getLoc $ lnames !! (idx - 1) 486 endLoc' = if idx == 0 && idx < length lnames - 1 487 then srcSpanStart . getLoc $ lnames !! (idx + 1) 488 else endLoc 489 in Just (mkSrcSpan startLoc' endLoc', False) 490 findRelatedSigSpan1 _ _ = Nothing 491 492 -- for where clause 493 findRelatedSpanForMatch 494 :: PositionIndexedString 495 -> String 496 -> LMatch GhcPs (LHsExpr GhcPs) 497 -> [Range] 498 findRelatedSpanForMatch 499 indexedContent 500 name 501 (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do 502 case grhssLocalBinds of 503 (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> 504 if isEmptyBag bag 505 then [] 506 else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag 507 _ -> [] 508 findRelatedSpanForMatch _ _ _ = [] 509 510 findRelatedSpanForHsBind 511 :: PositionIndexedString 512 -> String 513 -> [LSig GhcPs] 514 -> LHsBind GhcPs 515 -> [Range] 516 findRelatedSpanForHsBind 517 indexedContent 518 name 519 lsigs 520 (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = 521 if isTheBinding (getLoc lname) 522 then 523 let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig 524 findSig _ = [] 525 in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs 526 else concatMap (findRelatedSpanForMatch indexedContent name) matches 527 findRelatedSpanForHsBind _ _ _ _ = [] 528 529 isTheBinding :: SrcSpan -> Bool 530 isTheBinding span = srcSpanToRange span == Just _range 531 532 isSameName :: IdP GhcPs -> String -> Bool 533 isSameName x name = showSDocUnsafe (ppr x) == name 534 535data ExportsAs = ExportName | ExportPattern | ExportAll 536 deriving (Eq) 537 538getLocatedRange :: Located a -> Maybe Range 539getLocatedRange = srcSpanToRange . getLoc 540 541suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)] 542suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} 543-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’ 544-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’ 545-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’ 546 | Just source <- srcOpt 547 , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’" 548 <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’" 549 <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’" 550 , Just (exportType, _) <- find (matchWithDiagnostic _range . snd) 551 . mapMaybe 552 (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l 553 then exportsAs b else Nothing) 554 $ hsmodDecls 555 , Just pos <- fmap _end . getLocatedRange =<< hsmodExports 556 , Just needComma <- needsComma source <$> hsmodExports 557 , let exportName = (if needComma then "," else "") <> printExport exportType name 558 insertPos = pos {_character = pred $ _character pos} 559 = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)] 560 | otherwise = [] 561 where 562 -- we get the last export and the closing bracket and check for comma in that range 563 needsComma :: T.Text -> Located [LIE GhcPs] -> Bool 564 needsComma _ (L _ []) = False 565 needsComma source (L (OldRealSrcSpan l) exports) = 566 let closeParan = _end $ realSrcSpanToRange l 567 lastExport = fmap _end . getLocatedRange $ last exports 568 in case lastExport of 569 Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source 570 _ -> False 571 needsComma _ _ = False 572 573 opLetter :: String 574 opLetter = ":!#$%&*+./<=>?@\\^|-~" 575 576 parenthesizeIfNeeds :: Bool -> T.Text -> T.Text 577 parenthesizeIfNeeds needsTypeKeyword x 578 | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")" 579 | otherwise = x 580 581 matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool 582 matchWithDiagnostic Range{_start=l,_end=r} x = 583 let loc = fmap _start . getLocatedRange $ x 584 in loc >= Just l && loc <= Just r 585 586 printExport :: ExportsAs -> T.Text -> T.Text 587 printExport ExportName x = parenthesizeIfNeeds False x 588 printExport ExportPattern x = "pattern " <> x 589 printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" 590 591 isTopLevel :: Range -> Bool 592 isTopLevel l = (_character . _start) l == 0 593 594 exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p)) 595 exportsAs (ValD _ FunBind {fun_id}) = Just (ExportName, fun_id) 596 exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, psb_id) 597 exportsAs (TyClD _ SynDecl{tcdLName}) = Just (ExportName, tcdLName) 598 exportsAs (TyClD _ DataDecl{tcdLName}) = Just (ExportAll, tcdLName) 599 exportsAs (TyClD _ ClassDecl{tcdLName}) = Just (ExportAll, tcdLName) 600 exportsAs (TyClD _ FamDecl{tcdFam}) = Just (ExportAll, fdLName tcdFam) 601 exportsAs _ = Nothing 602 603suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] 604suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..} 605-- File.hs:52:41: warning: 606-- * Defaulting the following constraint to type ‘Integer’ 607-- Num p0 arising from the literal ‘1’ 608-- * In the expression: 1 609-- In an equation for ‘f’: f = 1 610-- File.hs:52:41: warning: 611-- * Defaulting the following constraints to type ‘[Char]’ 612-- (Show a0) 613-- arising from a use of ‘traceShow’ 614-- at A.hs:228:7-25 615-- (IsString a0) 616-- arising from the literal ‘"debug"’ 617-- at A.hs:228:17-23 618-- * In the expression: traceShow "debug" a 619-- In an equation for ‘f’: f a = traceShow "debug" a 620-- File.hs:52:41: warning: 621-- * Defaulting the following constraints to type ‘[Char]’ 622-- (Show a0) 623-- arising from a use of ‘traceShow’ 624-- at A.hs:255:28-43 625-- (IsString a0) 626-- arising from the literal ‘"test"’ 627-- at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43 628-- * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’ 629-- In the expression: seq "test" seq "test" (traceShow "test") 630-- In an equation for ‘f’: 631-- f = seq "test" seq "test" (traceShow "test") 632 | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False) 633 <|> matchRegexUnifySpaces _message (pat False False False True) 634 <|> matchRegexUnifySpaces _message (pat False False False False) 635 = codeEdit ty lit (makeAnnotatedLit ty lit) 636 | Just source <- sourceOpt 637 , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False) 638 = let lit' = makeAnnotatedLit ty lit; 639 tir = textInRange _range source 640 in codeEdit ty lit (T.replace lit lit' tir) 641 | otherwise = [] 642 where 643 makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")" 644 pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint" 645 , if multiple then "s" else "" 646 , " to type ‘([^ ]+)’ " 647 , ".*arising from the literal ‘(.+)’" 648 , if inArg then ".+In the.+argument" else "" 649 , if at then ".+at" else "" 650 , if inExpr then ".+In the expression" else "" 651 , ".+In the expression" 652 ] 653 codeEdit ty lit replacement = 654 let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’" 655 edits = [TextEdit _range replacement] 656 in [( title, edits )] 657 658 659suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] 660suggestReplaceIdentifier contents Diagnostic{_range=_range,..} 661-- File.hs:52:41: error: 662-- * Variable not in scope: 663-- suggestAcion :: Maybe T.Text -> Range -> Range 664-- * Perhaps you meant ‘suggestAction’ (line 83) 665-- File.hs:94:37: error: 666-- Not in scope: ‘T.isPrfixOf’ 667-- Perhaps you meant one of these: 668-- ‘T.isPrefixOf’ (imported from Data.Text), 669-- ‘T.isInfixOf’ (imported from Data.Text), 670-- ‘T.isSuffixOf’ (imported from Data.Text) 671-- Module ‘Data.Text’ does not export ‘isPrfixOf’. 672 | renameSuggestions@(_:_) <- extractRenamableTerms _message 673 = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ] 674 | otherwise = [] 675 676suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] 677suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range} 678-- * Variable not in scope: 679-- suggestAcion :: Maybe T.Text -> Range -> Range 680 | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)" 681 = newDefinitionAction ideOptions parsedModule _range name typ 682 | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps" 683 , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ 684 = [(label, mkRenameEdit contents _range name : newDefinitionEdits)] 685 | otherwise = [] 686 where 687 message = unifySpaces _message 688 689newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])] 690newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ 691 | Range _ lastLineP : _ <- 692 [ realSrcSpanToRange sp 693 | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls 694 , _start `isInsideSrcSpan` l] 695 , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} 696 = [ ("Define " <> sig 697 , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])] 698 )] 699 | otherwise = [] 700 where 701 colon = if optNewColonConvention then " : " else " :: " 702 sig = name <> colon <> T.dropWhileEnd isSpace typ 703 ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule 704 705 706suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] 707suggestFillTypeWildcard Diagnostic{_range=_range,..} 708-- Foo.hs:3:8: error: 709-- * Found type wildcard `_' standing for `p -> p1 -> p' 710 711 | "Found type wildcard" `T.isInfixOf` _message 712 , " standing for " `T.isInfixOf` _message 713 , typeSignature <- extractWildCardTypeSignature _message 714 = [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)] 715 | otherwise = [] 716 717suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)] 718suggestModuleTypo Diagnostic{_range=_range,..} 719-- src/Development/IDE/Core/Compile.hs:58:1: error: 720-- Could not find module ‘Data.Cha’ 721-- Perhaps you meant Data.Char (from base-4.12.0.0) 722 | "Could not find module" `T.isInfixOf` _message 723 , "Perhaps you meant" `T.isInfixOf` _message = let 724 findSuggestedModules = map (head . T.words) . drop 2 . T.lines 725 proposeModule mod = ("replace with " <> mod, TextEdit _range mod) 726 in map proposeModule $ nubOrd $ findSuggestedModules _message 727 | otherwise = [] 728 729suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] 730suggestFillHole Diagnostic{_range=_range,..} 731 | Just holeName <- extractHoleName _message 732 , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) = 733 let isInfixHole = _message =~ addBackticks holeName :: Bool in 734 map (proposeHoleFit holeName False isInfixHole) holeFits 735 ++ map (proposeHoleFit holeName True isInfixHole) refFits 736 | otherwise = [] 737 where 738 extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" 739 addBackticks text = "`" <> text <> "`" 740 addParens text = "(" <> text <> ")" 741 proposeHoleFit holeName parenthise isInfixHole name = 742 let isInfixOperator = T.head name == '(' 743 name' = getOperatorNotation isInfixHole isInfixOperator name in 744 ( "replace " <> holeName <> " with " <> name 745 , TextEdit _range (if parenthise then addParens name' else name') 746 ) 747 getOperatorNotation True False name = addBackticks name 748 getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name) 749 getOperatorNotation _isInfixHole _isInfixOperator name = name 750 751processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) 752processHoleSuggestions mm = (holeSuggestions, refSuggestions) 753{- 754 • Found hole: _ :: LSP.Handlers 755 756 Valid hole fits include def 757 Valid refinement hole fits include 758 fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers) 759 fromJust (_ :: Maybe LSP.Handlers) 760 haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams 761 LSP.Handlers) 762 T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers) 763 (_ :: LSP.Handlers) 764 (_ :: T.Text) 765 T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers) 766 (_ :: LSP.Handlers) 767 (_ :: T.Text) 768-} 769 where 770 t = id @T.Text 771 holeSuggestions = do 772 -- get the text indented under Valid hole fits 773 validHolesSection <- 774 getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm 775 -- the Valid hole fits line can contain a hole fit 776 holeFitLine <- 777 mapHead 778 (mrAfter . (=~ t " *Valid (hole fits|substitutions) include")) 779 validHolesSection 780 let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine 781 guard (not $ T.null holeFit) 782 return holeFit 783 refSuggestions = do -- @[] 784 -- get the text indented under Valid refinement hole fits 785 refinementSection <- 786 getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm 787 -- get the text for each hole fit 788 holeFitLines <- getIndentedGroups (tail refinementSection) 789 let holeFit = T.strip $ T.unwords holeFitLines 790 guard $ not $ holeFit =~ t "Some refinement hole fits suppressed" 791 return holeFit 792 793 mapHead f (a:aa) = f a : aa 794 mapHead _ [] = [] 795 796-- > getIndentedGroups [" H1", " l1", " l2", " H2", " l3"] = [[" H1,", " l1", " l2"], [" H2", " l3"]] 797getIndentedGroups :: [T.Text] -> [[T.Text]] 798getIndentedGroups [] = [] 799getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll 800-- | 801-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", " l1", " l2", " H2", " l3"] = [[" H1", " l1", " l2"], [" H2", " l3"]] 802getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]] 803getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of 804 (l:ll) -> case span (\l' -> indentation l < indentation l') ll of 805 (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest 806 _ -> [] 807 808indentation :: T.Text -> Int 809indentation = T.length . T.takeWhile isSpace 810 811suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)] 812suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} 813 | Just [binding, mod, srcspan] <- 814 matchRegexUnifySpaces _message 815 "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" 816 = suggestions hsmodImports binding mod srcspan 817 | Just (binding, mod_srcspan) <- 818 matchRegExMultipleImports _message 819 = mod_srcspan >>= uncurry (suggestions hsmodImports binding) 820 | otherwise = [] 821 where 822 canUseDatacon = case extractNotInScopeName _message of 823 Just NotInScopeTypeConstructorOrClass{} -> False 824 _ -> True 825 826 suggestions decls binding mod srcspan 827 | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of 828 [s] -> let x = realSrcSpanToRange s 829 in x{_end = (_end x){_character = succ (_character (_end x))}} 830 _ -> error "bug in srcspan parser", 831 Just decl <- findImportDeclByRange decls range, 832 Just ident <- lookupExportMap binding mod 833 = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod 834 , quickFixImportKind' "extend" importStyle 835 , uncurry extendImport (unImportStyle importStyle) decl 836 ) 837 | importStyle <- NE.toList $ importStyles ident 838 ] 839 | otherwise = [] 840 lookupExportMap binding mod 841 | Just match <- Map.lookup binding (getExportsMap exportsMap) 842 -- Only for the situation that data constructor name is same as type constructor name, 843 -- let ident with parent be in front of the one without. 844 , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) 845 , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch 846 , (not . null) idents -- Ensure fallback while `idents` is empty 847 , ident <- head idents 848 = Just ident 849 850 -- fallback to using GHC suggestion even though it is not always correct 851 | otherwise 852 = Just IdentInfo 853 { name = mkVarOcc $ T.unpack binding 854 , rendered = binding 855 , parent = Nothing 856 , isDatacon = False 857 , moduleNameText = mod} 858 859data HidingMode 860 = HideOthers [ModuleTarget] 861 | ToQualified 862 Bool 863 -- ^ Parenthesised? 864 ModuleName 865 deriving (Show) 866 867data ModuleTarget 868 = ExistingImp (NonEmpty (LImportDecl GhcPs)) 869 | ImplicitPrelude [LImportDecl GhcPs] 870 deriving (Show) 871 872targetImports :: ModuleTarget -> [LImportDecl GhcPs] 873targetImports (ExistingImp ne) = NE.toList ne 874targetImports (ImplicitPrelude xs) = xs 875 876oneAndOthers :: [a] -> [(a, [a])] 877oneAndOthers = go 878 where 879 go [] = [] 880 go (x : xs) = (x, xs) : map (second (x :)) (go xs) 881 882isPreludeImplicit :: DynFlags -> Bool 883isPreludeImplicit = xopt Lang.ImplicitPrelude 884 885-- | Suggests disambiguation for ambiguous symbols. 886suggestImportDisambiguation :: 887 DynFlags -> 888 Maybe T.Text -> 889 ParsedSource -> 890 T.Text -> 891 Diagnostic -> 892 [(T.Text, [Either TextEdit Rewrite])] 893suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileContents diag@Diagnostic {..} 894 | Just [ambiguous] <- 895 matchRegexUnifySpaces 896 _message 897 "Ambiguous occurrence ‘([^’]+)’" 898 , Just modules <- 899 map last 900 <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" = 901 suggestions ambiguous modules 902 | otherwise = [] 903 where 904 locDic = 905 fmap (NE.fromList . DL.toList) $ 906 Map.fromListWith (<>) $ 907 map 908 ( \i@(L _ idecl) -> 909 ( T.pack $ moduleNameString $ unLoc $ ideclName idecl 910 , DL.singleton i 911 ) 912 ) 913 hsmodImports 914 toModuleTarget "Prelude" 915 | isPreludeImplicit df 916 = Just $ ImplicitPrelude $ 917 maybe [] NE.toList (Map.lookup "Prelude" locDic) 918 toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic 919 parensed = 920 "(" `T.isPrefixOf` T.strip (textInRange _range txt) 921 -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] 922 removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort 923 hasDuplicate xs = length xs /= length (S.fromList xs) 924 suggestions symbol mods 925 | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of 926 Just targets -> suggestionsImpl symbol (map (, []) targets) 927 Nothing -> [] 928 | otherwise = case mapM toModuleTarget mods of 929 Just targets -> suggestionsImpl symbol (oneAndOthers targets) 930 Nothing -> [] 931 suggestionsImpl symbol targetsWithRestImports = 932 sortOn fst 933 [ ( renderUniquify mode modNameText symbol 934 , disambiguateSymbol ps fileContents diag symbol mode 935 ) 936 | (modTarget, restImports) <- targetsWithRestImports 937 , let modName = targetModuleName modTarget 938 modNameText = T.pack $ moduleNameString modName 939 , mode <- 940 [ ToQualified parensed qual 941 | ExistingImp imps <- [modTarget] 942#if MIN_VERSION_ghc(9,0,0) 943 {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} 944 -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation 945 -- nubOrd can't be used since SrcSpan is intentionally no Ord 946 , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) 947#else 948 , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) 949#endif 950 $ NE.toList imps 951 ] 952 ++ [ToQualified parensed modName 953 | any (occursUnqualified symbol . unLoc) 954 (targetImports modTarget) 955 || case modTarget of 956 ImplicitPrelude{} -> True 957 _ -> False 958 ] 959 ++ [HideOthers restImports | not (null restImports)] 960 ] 961 renderUniquify HideOthers {} modName symbol = 962 "Use " <> modName <> " for " <> symbol <> ", hiding other imports" 963 renderUniquify (ToQualified _ qual) _ symbol = 964 "Replace with qualified: " 965 <> T.pack (moduleNameString qual) 966 <> "." 967 <> symbol 968suggestImportDisambiguation _ _ _ _ _ = [] 969 970occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool 971occursUnqualified symbol ImportDecl{..} 972 | isNothing ideclAs = Just False /= 973 -- I don't find this particularly comprehensible, 974 -- but HLint suggested me to do so... 975 (ideclHiding <&> \(isHiding, L _ ents) -> 976 let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents 977 in isHiding && not occurs || not isHiding && occurs 978 ) 979occursUnqualified _ _ = False 980 981symbolOccursIn :: T.Text -> IE GhcPs -> Bool 982symbolOccursIn symb = any ((== symb). showNameWithoutUniques) . ieNames 983 984targetModuleName :: ModuleTarget -> ModuleName 985targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" 986targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = 987 unLoc ideclName 988targetModuleName (ExistingImp _) = 989 error "Cannot happen!" 990 991disambiguateSymbol :: 992 ParsedSource -> 993 T.Text -> 994 Diagnostic -> 995 T.Text -> 996 HidingMode -> 997 [Either TextEdit Rewrite] 998disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case 999 (HideOthers hiddens0) -> 1000 [ Right $ hideSymbol symbol idecl 1001 | ExistingImp idecls <- hiddens0 1002 , idecl <- NE.toList idecls 1003 ] 1004 ++ mconcat 1005 [ if null imps 1006 then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) pm fileContents 1007 else Right . hideSymbol symbol <$> imps 1008 | ImplicitPrelude imps <- hiddens0 1009 ] 1010 (ToQualified parensed qualMod) -> 1011 let occSym = mkVarOcc symbol 1012 rdr = Qual qualMod occSym 1013 in Right <$> [ if parensed 1014 then Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df -> 1015 liftParseAST @(HsExpr GhcPs) df $ 1016 prettyPrint $ 1017 HsVar @GhcPs noExtField $ 1018 L (oldUnhelpfulSpan "") rdr 1019 else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df -> 1020 liftParseAST @RdrName df $ 1021 prettyPrint $ L (oldUnhelpfulSpan "") rdr 1022 ] 1023 1024findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) 1025findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs 1026 1027suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)] 1028suggestFixConstructorImport Diagnostic{_range=_range,..} 1029 -- ‘Success’ is a data constructor of ‘Result’ 1030 -- To import it use 1031 -- import Data.Aeson.Types( Result( Success ) ) 1032 -- or 1033 -- import Data.Aeson.Types( Result(..) ) (lsp-ui) 1034 | Just [constructor, typ] <- 1035 matchRegexUnifySpaces _message 1036 "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use" 1037 = let fixedImport = typ <> "(" <> constructor <> ")" 1038 in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] 1039 | otherwise = [] 1040-- | Suggests a constraint for a declaration for which a constraint is missing. 1041suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] 1042suggestConstraint df parsedModule diag@Diagnostic {..} 1043 | Just missingConstraint <- findMissingConstraint _message 1044 = let codeAction = if _message =~ ("the type signature for:" :: String) 1045 then suggestFunctionConstraint df parsedModule 1046 else suggestInstanceConstraint df parsedModule 1047 in codeAction diag missingConstraint 1048 | otherwise = [] 1049 where 1050 findMissingConstraint :: T.Text -> Maybe T.Text 1051 findMissingConstraint t = 1052 let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement 1053 regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" 1054 match = matchRegexUnifySpaces t regex 1055 matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams 1056 in match <|> matchImplicitParams <&> last 1057 1058-- | Suggests a constraint for an instance declaration for which a constraint is missing. 1059suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] 1060 1061suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint 1062 | Just instHead <- instanceHead 1063 = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)] 1064 | otherwise = [] 1065 where 1066 instanceHead 1067 -- Suggests a constraint for an instance declaration with no existing constraints. 1068 -- • No instance for (Eq a) arising from a use of ‘==’ 1069 -- Possible fix: add (Eq a) to the context of the instance declaration 1070 -- • In the expression: x == y 1071 -- In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y 1072 -- In the instance declaration for ‘Eq (Wrap a)’ 1073 | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’" 1074 , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls 1075 = Just instHead 1076 -- Suggests a constraint for an instance declaration with one or more existing constraints. 1077 -- • Could not deduce (Eq b) arising from a use of ‘==’ 1078 -- from the context: Eq a 1079 -- bound by the instance declaration at /path/to/Main.hs:7:10-32 1080 -- Possible fix: add (Eq b) to the context of the instance declaration 1081 -- • In the second argument of ‘(&&)’, namely ‘x' == y'’ 1082 -- In the expression: x == y && x' == y' 1083 -- In an equation for ‘==’: 1084 -- (Pair x x') == (Pair y y') = x == y && x' == y' 1085 | Just [instanceLineStr, constraintFirstCharStr] 1086 <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)" 1087 , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}}))) 1088 <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls 1089 = Just hsib_body 1090 | otherwise 1091 = Nothing 1092 1093 readPositionNumber :: T.Text -> Int 1094 readPositionNumber = T.unpack >>> read 1095 1096 actionTitle :: T.Text -> T.Text 1097 actionTitle constraint = "Add `" <> constraint 1098 <> "` to the context of the instance declaration" 1099 1100suggestImplicitParameter :: 1101 ParsedSource -> 1102 Diagnostic -> 1103 [(T.Text, Rewrite)] 1104suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} 1105 | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", 1106 Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, 1107 Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls 1108 = 1109 [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) 1110 , appendConstraint (T.unpack implicitT) hsib_body)] 1111 | otherwise = [] 1112 1113findTypeSignatureName :: T.Text -> Maybe T.Text 1114findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head 1115 1116-- | Suggests a constraint for a type signature with any number of existing constraints. 1117suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] 1118 1119suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint 1120-- • No instance for (Eq a) arising from a use of ‘==’ 1121-- Possible fix: 1122-- add (Eq a) to the context of 1123-- the type signature for: 1124-- eq :: forall a. a -> a -> Bool 1125-- • In the expression: x == y 1126-- In an equation for ‘eq’: eq x y = x == y 1127 1128-- • Could not deduce (Eq b) arising from a use of ‘==’ 1129-- from the context: Eq a 1130-- bound by the type signature for: 1131-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool 1132-- at Main.hs:5:1-42 1133-- Possible fix: 1134-- add (Eq b) to the context of 1135-- the type signature for: 1136-- eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool 1137-- • In the second argument of ‘(&&)’, namely ‘y == y'’ 1138-- In the expression: x == x' && y == y' 1139-- In an equation for ‘eq’: 1140-- eq (Pair x y) (Pair x' y') = x == x' && y == y' 1141 | Just typeSignatureName <- findTypeSignatureName _message 1142 , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) 1143 <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls 1144 , title <- actionTitle missingConstraint typeSignatureName 1145 = [(title, appendConstraint (T.unpack missingConstraint) sig)] 1146 | otherwise 1147 = [] 1148 where 1149 actionTitle :: T.Text -> T.Text -> T.Text 1150 actionTitle constraint typeSignatureName = "Add `" <> constraint 1151 <> "` to the context of the type signature for `" <> typeSignatureName <> "`" 1152 1153-- | Suggests the removal of a redundant constraint for a type signature. 1154removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] 1155removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} 1156-- • Redundant constraint: Eq a 1157-- • In the type signature for: 1158-- foo :: forall a. Eq a => a -> a 1159-- • Redundant constraints: (Monoid a, Show a) 1160-- • In the type signature for: 1161-- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool 1162 -- Account for both "Redundant constraint" and "Redundant constraints". 1163 | "Redundant constraint" `T.isInfixOf` _message 1164 , Just typeSignatureName <- findTypeSignatureName _message 1165 , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) 1166 <- findSigOfDeclRanged _range hsmodDecls 1167 , Just redundantConstraintList <- findRedundantConstraints _message 1168 , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig 1169 = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] 1170 | otherwise = [] 1171 where 1172 toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list) 1173 1174 parseConstraints :: T.Text -> [T.Text] 1175 parseConstraints t = t 1176 & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") 1177 <&> T.strip 1178 1179 stripConstraintsParens :: T.Text -> T.Text 1180 stripConstraintsParens constraints = 1181 if "(" `T.isPrefixOf` constraints 1182 then constraints & T.drop 1 & T.dropEnd 1 & T.strip 1183 else constraints 1184 1185 findRedundantConstraints :: T.Text -> Maybe [T.Text] 1186 findRedundantConstraints t = t 1187 & T.lines 1188 & head 1189 & T.strip 1190 & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)") 1191 <&> (head >>> parseConstraints) 1192 1193 formatConstraints :: [T.Text] -> T.Text 1194 formatConstraints [] = "" 1195 formatConstraints [constraint] = constraint 1196 formatConstraints constraintList = constraintList 1197 & T.intercalate ", " 1198 & \cs -> "(" <> cs <> ")" 1199 1200 actionTitle :: [T.Text] -> T.Text -> T.Text 1201 actionTitle constraintList typeSignatureName = 1202 "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" 1203 <> formatConstraints constraintList 1204 <> "` from the context of the type signature for `" <> typeSignatureName <> "`" 1205 1206------------------------------------------------------------------------------------------------- 1207 1208suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] 1209suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} 1210 | Just [methodName, className] <- 1211 matchRegexUnifySpaces 1212 _message 1213 "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", 1214 idents <- 1215 maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $ 1216 Map.lookup methodName $ getExportsMap packageExportsMap = 1217 mconcat $ suggest <$> idents 1218 | otherwise = [] 1219 where 1220 suggest identInfo@IdentInfo {moduleNameText} 1221 | importStyle <- NE.toList $ importStyles identInfo, 1222 mImportDecl <- findImportDeclByModuleName (hsmodImports $ unLoc ps) (T.unpack moduleNameText) = 1223 case mImportDecl of 1224 -- extend 1225 Just decl -> 1226 [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText, 1227 quickFixImportKind' "extend" style, 1228 [Right $ uncurry extendImport (unImportStyle style) decl] 1229 ) 1230 | style <- importStyle 1231 ] 1232 -- new 1233 _ 1234 | Just (range, indent) <- newImportInsertRange ps fileContents 1235 -> 1236 (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$> 1237 [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False) 1238 | style <- importStyle, 1239 let rendered = renderImportStyle style 1240 ] 1241 <> [(quickFixImportKind "new.all", newImportAll moduleNameText)] 1242 | otherwise -> [] 1243 1244suggestNewImport :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] 1245suggestNewImport packageExportsMap ps@(L _ HsModule {..}) fileContents Diagnostic{_message} 1246 | msg <- unifySpaces _message 1247 , Just thingMissing <- extractNotInScopeName msg 1248 , qual <- extractQualifiedModuleName msg 1249 , qual' <- 1250 extractDoesNotExportModuleName msg 1251 >>= (findImportDeclByModuleName hsmodImports . T.unpack) 1252 >>= ideclAs . unLoc 1253 <&> T.pack . moduleNameString . unLoc 1254 , Just (range, indent) <- newImportInsertRange ps fileContents 1255 , extendImportSuggestions <- matchRegexUnifySpaces msg 1256 "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" 1257 = sortOn fst3 [(imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " ")) 1258 | (kind, unNewImport -> imp) <- constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions 1259 ] 1260suggestNewImport _ _ _ _ = [] 1261 1262constructNewImportSuggestions 1263 :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)] 1264constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd 1265 [ suggestion 1266 | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] 1267 , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) 1268 , canUseIdent thingMissing identInfo 1269 , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules 1270 , suggestion <- renderNewImport identInfo 1271 ] 1272 where 1273 renderNewImport :: IdentInfo -> [(CodeActionKind, NewImport)] 1274 renderNewImport identInfo 1275 | Just q <- qual 1276 = [(quickFixImportKind "new.qualified", newQualImport m q)] 1277 | otherwise 1278 = [(quickFixImportKind' "new" importStyle, newUnqualImport m (renderImportStyle importStyle) False) 1279 | importStyle <- NE.toList $ importStyles identInfo] ++ 1280 [(quickFixImportKind "new.all", newImportAll m)] 1281 where 1282 m = moduleNameText identInfo 1283 1284newtype NewImport = NewImport {unNewImport :: T.Text} 1285 deriving (Show, Eq, Ord) 1286 1287newImportToEdit :: NewImport -> ParsedSource -> T.Text -> Maybe (T.Text, TextEdit) 1288newImportToEdit (unNewImport -> imp) ps fileContents 1289 | Just (range, indent) <- newImportInsertRange ps fileContents 1290 = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " ")) 1291 | otherwise = Nothing 1292 1293-- | Finds the next valid position for inserting a new import declaration 1294-- * If the file already has existing imports it will be inserted under the last of these, 1295-- it is assumed that the existing last import declaration is in a valid position 1296-- * If the file does not have existing imports, but has a (module ... where) declaration, 1297-- the new import will be inserted directly under this declaration (accounting for explicit exports) 1298-- * If the file has neither existing imports nor a module declaration, 1299-- the import will be inserted at line zero if there are no pragmas, 1300-- * otherwise inserted one line after the last file-header pragma 1301newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int) 1302newImportInsertRange (L _ HsModule {..}) fileContents 1303 | Just (uncurry Position -> insertPos, col) <- case hsmodImports of 1304 [] -> findPositionNoImports hsmodName hsmodExports fileContents 1305 _ -> findPositionFromImportsOrModuleDecl hsmodImports last True 1306 = Just (Range insertPos insertPos, col) 1307 | otherwise = Nothing 1308 1309-- | Insert the import under the Module declaration exports if they exist, otherwise just under the module declaration. 1310-- If no module declaration exists, then no exports will exist either, in that case 1311-- insert the import after any file-header pragmas or at position zero if there are no pragmas 1312findPositionNoImports :: Maybe (Located ModuleName) -> Maybe (Located [LIE name]) -> T.Text -> Maybe ((Int, Int), Int) 1313findPositionNoImports Nothing _ fileContents = findNextPragmaPosition fileContents 1314findPositionNoImports _ (Just hsmodExports) _ = findPositionFromImportsOrModuleDecl hsmodExports id False 1315findPositionNoImports (Just hsmodName) _ _ = findPositionFromImportsOrModuleDecl hsmodName id False 1316 1317findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int) 1318findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of 1319 OldRealSrcSpan s -> 1320 let col = calcCol s 1321 in Just ((srcLocLine (realSrcSpanEnd s), col), col) 1322 _ -> Nothing 1323 where calcCol s = if hasImports then srcLocCol (realSrcSpanStart s) - 1 else 0 1324 1325-- | Find the position one after the last file-header pragma 1326-- Defaults to zero if there are no pragmas in file 1327findNextPragmaPosition :: T.Text -> Maybe ((Int, Int), Int) 1328findNextPragmaPosition contents = Just ((lineNumber, 0), 0) 1329 where 1330 lineNumber = afterLangPragma . afterOptsGhc $ afterShebang 1331 afterLangPragma = afterPragma "LANGUAGE" contents' 1332 afterOptsGhc = afterPragma "OPTIONS_GHC" contents' 1333 afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0 1334 contents' = T.lines contents 1335 1336afterPragma :: T.Text -> [T.Text] -> Int -> Int 1337afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum 1338 1339lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int 1340lastLineWithPrefix p contents lineNum = max lineNum next 1341 where 1342 next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents 1343 1344checkPragma :: T.Text -> T.Text -> Bool 1345checkPragma name = check 1346 where 1347 check l = isPragma l && getName l == name 1348 getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l 1349 isPragma = T.isPrefixOf "{-#" 1350 1351-- | Construct an import declaration with at most one symbol 1352newImport 1353 :: T.Text -- ^ module name 1354 -> Maybe T.Text -- ^ the symbol 1355 -> Maybe T.Text -- ^ qualified name 1356 -> Bool -- ^ the symbol is to be imported or hidden 1357 -> NewImport 1358newImport modName mSymbol mQual hiding = NewImport impStmt 1359 where 1360 symImp 1361 | Just symbol <- mSymbol 1362 , symOcc <- mkVarOcc $ T.unpack symbol = 1363 " (" <> T.pack (unsafePrintSDoc (parenSymOcc symOcc $ ppr symOcc)) <> ")" 1364 | otherwise = "" 1365 impStmt = 1366 "import " 1367 <> maybe "" (const "qualified ") mQual 1368 <> modName 1369 <> (if hiding then " hiding" else "") 1370 <> symImp 1371 <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual 1372 1373newQualImport :: T.Text -> T.Text -> NewImport 1374newQualImport modName qual = newImport modName Nothing (Just qual) False 1375 1376newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport 1377newUnqualImport modName symbol = newImport modName (Just symbol) Nothing 1378 1379newImportAll :: T.Text -> NewImport 1380newImportAll modName = newImport modName Nothing Nothing False 1381 1382hideImplicitPreludeSymbol :: T.Text -> NewImport 1383hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True 1384 1385canUseIdent :: NotInScope -> IdentInfo -> Bool 1386canUseIdent NotInScopeDataConstructor{} = isDatacon 1387canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon 1388canUseIdent _ = const True 1389 1390data NotInScope 1391 = NotInScopeDataConstructor T.Text 1392 | NotInScopeTypeConstructorOrClass T.Text 1393 | NotInScopeThing T.Text 1394 deriving Show 1395 1396notInScope :: NotInScope -> T.Text 1397notInScope (NotInScopeDataConstructor t) = t 1398notInScope (NotInScopeTypeConstructorOrClass t) = t 1399notInScope (NotInScopeThing t) = t 1400 1401extractNotInScopeName :: T.Text -> Maybe NotInScope 1402extractNotInScopeName x 1403 | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)" 1404 = Just $ NotInScopeDataConstructor name 1405 | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’" 1406 = Just $ NotInScopeDataConstructor name 1407 | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" 1408 = Just $ NotInScopeTypeConstructorOrClass name 1409 | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)" 1410 = Just $ NotInScopeThing name 1411 | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)" 1412 = Just $ NotInScopeThing name 1413 | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’" 1414 = Just $ NotInScopeThing name 1415 | otherwise 1416 = Nothing 1417 1418extractQualifiedModuleName :: T.Text -> Maybe T.Text 1419extractQualifiedModuleName x 1420 | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" 1421 = Just m 1422 | otherwise 1423 = Nothing 1424 1425-- | If a module has been imported qualified, and we want to ues the same qualifier for other modules 1426-- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier 1427-- from the imported one. 1428-- 1429-- For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s): 1430-- 1. 1431-- import qualified Data.Text as T 1432-- 1433-- Module ‘Data.Text’ does not export ‘putStrLn’. 1434-- 1435-- 2. 1436-- import qualified Data.Text as T 1437-- import qualified Data.Functor as T 1438-- 1439-- Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. 1440-- 1441-- 3. 1442-- import qualified Data.Text as T 1443-- import qualified Data.Functor as T 1444-- import qualified Data.Function as T 1445-- 1446-- Neither ‘Data.Function’, 1447-- ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’. 1448extractDoesNotExportModuleName :: T.Text -> Maybe T.Text 1449extractDoesNotExportModuleName x 1450 | Just [m] <- 1451 matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export" 1452 <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports" 1453 = Just m 1454 | otherwise 1455 = Nothing 1456------------------------------------------------------------------------------------------------- 1457 1458 1459mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit 1460mkRenameEdit contents range name = 1461 if maybeIsInfixFunction == Just True 1462 then TextEdit range ("`" <> name <> "`") 1463 else TextEdit range name 1464 where 1465 maybeIsInfixFunction = do 1466 curr <- textInRange range <$> contents 1467 pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr 1468 1469extractWildCardTypeSignature :: T.Text -> T.Text 1470extractWildCardTypeSignature = 1471 -- inferring when parens are actually needed around the type signature would 1472 -- require understanding both the precedence of the context of the _ and of 1473 -- the signature itself. Inserting them unconditionally is ugly but safe. 1474 ("(" `T.append`) . (`T.append` ")") . 1475 T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') . 1476 snd . T.breakOnEnd "standing for " 1477 1478extractRenamableTerms :: T.Text -> [T.Text] 1479extractRenamableTerms msg 1480 -- Account for both "Variable not in scope" and "Not in scope" 1481 | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg 1482 | otherwise = [] 1483 where 1484 extractSuggestions = map getEnclosed 1485 . concatMap singleSuggestions 1486 . filter isKnownSymbol 1487 . T.lines 1488 singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited 1489 isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t 1490 getEnclosed = T.dropWhile (== '‘') 1491 . T.dropWhileEnd (== '’') 1492 . T.dropAround (\c -> c /= '‘' && c /= '’') 1493 1494-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace 1495-- between the end of the range and the next newline), extend the range to take up the whole line. 1496extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range 1497extendToWholeLineIfPossible contents range@Range{..} = 1498 let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents 1499 extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line 1500 in if extend then Range _start (Position (_line _end + 1) 0) else range 1501 1502splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text) 1503splitTextAtPosition (Position row col) x 1504 | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x 1505 , (preCol, postCol) <- T.splitAt col mid 1506 = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) 1507 | otherwise = (x, T.empty) 1508 1509-- | Returns [start .. end[ 1510textInRange :: Range -> T.Text -> T.Text 1511textInRange (Range (Position startRow startCol) (Position endRow endCol)) text = 1512 case compare startRow endRow of 1513 LT -> 1514 let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine 1515 (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of 1516 [] -> ("", []) 1517 firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween) 1518 maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines 1519 in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine) 1520 EQ -> 1521 let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine) 1522 in T.take (endCol - startCol) (T.drop startCol line) 1523 GT -> "" 1524 where 1525 linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) 1526 1527-- | Returns the ranges for a binding in an import declaration 1528rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] 1529rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b = 1530 concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies 1531 where 1532 b' = wrapOperatorInParens b 1533rangesForBindingImport _ _ = [] 1534 1535wrapOperatorInParens :: String -> String 1536wrapOperatorInParens x = 1537 case uncons x of 1538 Just (h, _t) -> if isAlpha h then x else "(" <> x <> ")" 1539 Nothing -> mempty 1540 1541smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range] 1542smallerRangesForBindingExport lies b = 1543 concatMap (mapMaybe srcSpanToRange . ranges') lies 1544 where 1545 unqualify = snd . breakOnEnd "." 1546 b' = wrapOperatorInParens . unqualify $ b 1547 ranges' (L _ (IEThingWith _ thing _ inners labels)) 1548 | showSDocUnsafe (ppr thing) == b' = [] 1549 | otherwise = 1550 [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] ++ 1551 [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] 1552 ranges' _ = [] 1553 1554rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] 1555rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] 1556rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] 1557rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] 1558rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) 1559 | showSDocUnsafe (ppr thing) == b = [l] 1560 | otherwise = 1561 [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++ 1562 [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b] 1563rangesForBinding' _ _ = [] 1564 1565-- | 'matchRegex' combined with 'unifySpaces' 1566matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text] 1567matchRegexUnifySpaces message = matchRegex (unifySpaces message) 1568 1569-- | 'allMatchRegex' combined with 'unifySpaces' 1570allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]] 1571allMatchRegexUnifySpaces message = 1572 allMatchRegex (unifySpaces message) 1573 1574-- | Returns Just (the submatches) for the first capture, or Nothing. 1575matchRegex :: T.Text -> T.Text -> Maybe [T.Text] 1576matchRegex message regex = case message =~~ regex of 1577 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings 1578 Nothing -> Nothing 1579 1580-- | Returns Just (all matches) for the first capture, or Nothing. 1581allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]] 1582allMatchRegex message regex = message =~~ regex 1583 1584 1585unifySpaces :: T.Text -> T.Text 1586unifySpaces = T.unwords . T.words 1587 1588-- functions to help parse multiple import suggestions 1589 1590-- | Returns the first match if found 1591regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text 1592regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of 1593 Just (h:_) -> Just h 1594 _ -> Nothing 1595 1596-- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and 1597-- | return (Data.Map, app/ModuleB.hs:2:1-18) 1598regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text) 1599regExPair (modname, srcpair) = do 1600 x <- regexSingleMatch modname "‘([^’]*)’" 1601 y <- regexSingleMatch srcpair "\\((.*)\\)" 1602 return (x, y) 1603 1604-- | Process a list of (module_name, filename:src_span) values 1605-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] 1606regExImports :: T.Text -> Maybe [(T.Text, T.Text)] 1607regExImports msg = result 1608 where 1609 parts = T.words msg 1610 isPrefix = not . T.isPrefixOf "(" 1611 (mod, srcspan) = partition isPrefix parts 1612 -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18)) 1613 result = if length mod == length srcspan then 1614 regExPair `traverse` zip mod srcspan 1615 else Nothing 1616 1617matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)]) 1618matchRegExMultipleImports message = do 1619 let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$" 1620 (binding, imports) <- case matchRegexUnifySpaces message pat of 1621 Just [x, xs] -> Just (x, xs) 1622 _ -> Nothing 1623 imps <- regExImports imports 1624 return (binding, imps) 1625 1626-- | Possible import styles for an 'IdentInfo'. 1627-- 1628-- The first 'Text' parameter corresponds to the 'rendered' field of the 1629-- 'IdentInfo'. 1630data ImportStyle 1631 = ImportTopLevel T.Text 1632 -- ^ Import a top-level export from a module, e.g., a function, a type, a 1633 -- class. 1634 -- 1635 -- > import M (?) 1636 -- 1637 -- Some exports that have a parent, like a type-class method or an 1638 -- associated type/data family, can still be imported as a top-level 1639 -- import. 1640 -- 1641 -- Note that this is not the case for constructors, they must always be 1642 -- imported as part of their parent data type. 1643 1644 | ImportViaParent T.Text T.Text 1645 -- ^ Import an export (first parameter) through its parent (second 1646 -- parameter). 1647 -- 1648 -- import M (P(?)) 1649 -- 1650 -- @P@ and @?@ can be a data type and a constructor, a class and a method, 1651 -- a class and an associated type/data family, etc. 1652 deriving Show 1653 1654importStyles :: IdentInfo -> NonEmpty ImportStyle 1655importStyles IdentInfo {parent, rendered, isDatacon} 1656 | Just p <- parent 1657 -- Constructors always have to be imported via their parent data type, but 1658 -- methods and associated type/data families can also be imported as 1659 -- top-level exports. 1660 = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon] 1661 | otherwise 1662 = ImportTopLevel rendered :| [] 1663 1664-- | Used for adding new imports 1665renderImportStyle :: ImportStyle -> T.Text 1666renderImportStyle (ImportTopLevel x) = x 1667renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" 1668renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" 1669 1670-- | Used for extending import lists 1671unImportStyle :: ImportStyle -> (Maybe String, String) 1672unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) 1673unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) 1674 1675quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind 1676quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel" 1677quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent" 1678 1679quickFixImportKind :: T.Text -> CodeActionKind 1680quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x 1681