@@ -8,7 +8,6 @@
88-- | Go to the definition of a variable.
99module Development.IDE.Plugin.CodeAction(plugin) where
1010
11−import Avail (AvailInfo(Avail), AvailInfo(AvailTC), availNames)
1211import Language.Haskell.LSP.Types
1312import Control.Monad (join)
1413import Development.IDE.Plugin
@@ -21,8 +20,11 @@ import Development.IDE.GHC.Error
2120import Development.IDE.GHC.Util
2221import Development.IDE.LSP.Server
2322import Development.IDE.Plugin.CodeAction.PositionIndexed
23+import Development.IDE.Plugin.CodeAction.RuleTypes
24+import Development.IDE.Plugin.CodeAction.Rules
2425import Development.IDE.Types.Location
2526import Development.IDE.Types.Options
27+import Development.Shake (Rules)
2628import qualified Data.HashMap.Strict as Map
2729import qualified Language.Haskell.LSP.Core as LSP
2830import Language.Haskell.LSP.VFS
@@ -36,20 +38,18 @@ import Data.List.Extra
3638import qualified Data.Text as T
3739import Data.Tuple.Extra ((&&&))
3840import HscTypes
39−import OccName
4041import Parser
41−import RdrName
4242import Text.Regex.TDFA ((=~), (=~~))
4343import Text.Regex.TDFA.Text()
4444import Outputable (ppr, showSDocUnsafe)
4545import DynFlags (xFlags, FlagSpec(..))
4646import GHC.LanguageExtensions.Type (Extension)
47−import Data.IORef (readIORef)
48−import Name (isDataConName, nameModule_maybe, nameOccName)
49−import Packages (exposedModules, lookupPackage)
5047
5148plugin :: Plugin c
52−plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens
49+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
50+
51+rules :: Rules ()
52+rules = rulePackageExports
5353
5454-- | Generate code actions.
5555codeAction
@@ -65,15 +65,15 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
6565 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
6666 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
6767 mbFile = toNormalizedFilePath <$> uriToFilePath uri
68− (ideOptions, parsedModule, env) <- runAction state $
68+ (ideOptions, parsedModule, join -> env) <- runAction state $
6969 (,,) <$> getIdeOptions
70− <*> getParsedModule `traverse` mbFile
71− <*> use_ GhcSession `traverse` mbFile
70+ <*> getParsedModule `traverse` mbFile
71+ <*> use GhcSession `traverse` mbFile
72+ pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
7273 let dflags = hsc_dflags . hscEnv <$> env
73− eps <- traverse readIORef (hsc_EPS . hscEnv <$> env)
7474 pure $ Right
7575 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
76− | x <- xs, (title, tedit) <- suggestAction dflags eps ideOptions ( join parsedModule ) text x
76+ | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
7777 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
7878 ]
7979
@@ -114,13 +114,13 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
114114
115115suggestAction
116116 :: Maybe DynFlags
117− -> Maybe ExternalPackageState
117+ -> PackageExportsMap
118118 -> IdeOptions
119119 -> Maybe ParsedModule
120120 -> Maybe T.Text
121121 -> Diagnostic
122122 -> [(T.Text, [TextEdit])]
123−suggestAction dflags eps ideOptions parsedModule text diag = concat
123+suggestAction dflags packageExports ideOptions parsedModule text diag = concat
124124 [ suggestAddExtension diag
125125 , suggestExtendImport dflags text diag
126126 , suggestFillHole diag
@@ -132,7 +132,7 @@ suggestAction dflags eps ideOptions parsedModule text diag = concat
132132 ] ++ concat
133133 [ suggestNewDefinition ideOptions pm text diag
134134 ++ suggestRemoveRedundantImport pm text diag
135− ++ concat [suggestNewImport dflags eps pm diag | Just eps <- [eps], Just dflags <- [dflags]]
135+ ++ suggestNewImport packageExports pm diag
136136 | Just pm <- [parsedModule]]
137137
138138
@@ -304,15 +304,10 @@ suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
304304 _ -> error "bug in srcspan parser"
305305 importLine = textInRange range c
306306 in [("Add " <> binding <> " to the import list of " <> mod
307− , [TextEdit range (addBindingToImportList (printRdrName name) importLine)])]
307+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]
308308 | otherwise = []
309309suggestExtendImport Nothing _ _ = []
310310
311−printRdrName :: RdrName -> T.Text
312−printRdrName name = T.pack $ showSDocUnsafe $ parenSymOcc rn (ppr rn)
313− where
314− rn = rdrNameOcc name
315−
316311suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
317312suggestFixConstructorImport _ Diagnostic{_range=_range,..}
318313 -- ‘Success’ is a data constructor of ‘Result’
@@ -353,8 +348,8 @@ suggestSignature _ _ = []
353348
354349-------------------------------------------------------------------------------------------------
355350
356−suggestNewImport :: DynFlags -> ExternalPackageState -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
357−suggestNewImport dflags eps ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
351+suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
352+suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
358353 | msg <- unifySpaces _message
359354 , Just name <- extractNotInScopeName msg
360355 , Just insertLine <- case hsmodImports of
@@ -365,52 +360,36 @@ suggestNewImport dflags eps ParsedModule {pm_parsed_source = L _ HsModule {..}}
365360 RealSrcLoc s -> Just $ srcLocLine s
366361 _ -> Nothing
367362 , insertPos <- Position insertLine 0
368− , extendImportSuggestions <- -- Just [binding, mod, srcspan] <-
369− matchRegex msg
363+ , extendImportSuggestions <- matchRegex msg
370364 "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
371365 = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
372− | imp <- constructNewImportSuggestions dflags eps name extendImportSuggestions
366+ | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions
373367 ]
374−suggestNewImport _ _ _ _ = []
375−
376−constructNewImportSuggestions :: DynFlags -> ExternalPackageState -> NotInScope -> Maybe [T.Text] -> [T.Text]
377−constructNewImportSuggestions dflags eps thingMissing notTheseModules = nubOrd
378− [ case qual of
379− Nothing -> "import " <> modName <> " (" <> importWhat candidate avail <> ")"
380− Just q -> "import qualified " <> modName <> " as " <> q
381− | item <- items,
382− avail <- tyThingAvailInfo item,
383− canUseAvail thingMissing avail,
384− candidate <- availNames avail,
385− canUseName thingMissing candidate,
386− occNameString (nameOccName candidate) == T.unpack name,
387− Just m <- [nameModule_maybe candidate],
388− Just package <- [lookupPackage dflags (moduleUnitId m)],
389− moduleName m `elem` map fst (exposedModules package),
390− let modName = T.pack $ moduleNameString $ moduleName m,
391− modName `notElem` fromMaybe [] notTheseModules
392− ]
393− where
394− (qual, name) = case T.splitOn "." (notInScope thingMissing) of
395− [n] -> (Nothing, n)
396− segments -> (Just (T.concat $ init segments), last segments)
397− items = typeEnvElts $ eps_PTE eps
398− importWhat this (AvailTC parent _ _)
399− -- "Maybe(Just)"
400− | this /= parent
401− = T.pack (occNameString (nameOccName parent)) <>
402− "(" <> printName this <> ")"
403− importWhat this _ = printName this
404−
405− printName = printRdrName . nameRdrName
406−
407−canUseAvail :: NotInScope -> AvailInfo -> Bool
408−canUseAvail NotInScopeDataConstructor{} Avail{} = False
409−canUseAvail _ _ = True
410−
411−canUseName :: NotInScope -> Name -> Bool
412−canUseName NotInScopeDataConstructor{} = isDataConName
413−canUseName _ = const True
368+suggestNewImport _ _ _ = []
369+
370+constructNewImportSuggestions
371+ :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]
372+constructNewImportSuggestions 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 <> ")"
382+
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
389+
390+canUseIdent :: NotInScope -> IdentInfo -> Bool
391+canUseIdent NotInScopeDataConstructor{} = isDatacon
392+canUseIdent _ = const True
414393
415394data NotInScope
416395 = NotInScopeDataConstructor T.Text
@@ -427,6 +406,8 @@ extractNotInScopeName :: T.Text -> Maybe NotInScope
427406extractNotInScopeName x
428407 | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"
429408 = Just $ NotInScopeDataConstructor name
409+ | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"
410+ = Just $ NotInScopeDataConstructor name
430411 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
431412 = Just $ NotInScopeTypeConstructorOrClass name
432413 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"