Guess all imports (#459)

* Suggest missing imports via package exports map

At the expense of some space and initialization time, suggest imports now is
able to find suggestions in all the packages available to the project.

* BadDependency - include the key in the error message

* remove the assumption that the GhcSession is always available

* fix bad spacing

Co-Authored-By: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>

* Add type annotation to clarify rule being defined

* Remove file dependency from PackageExports rule

* Guess patterns

Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>

Author: pepeiborra

ghcide.cabal

@@ -139,6 +139,8 @@ library
         Development.IDE.Spans.Documentation
         Development.IDE.Spans.Type
         Development.IDE.Plugin.CodeAction.PositionIndexed
+        Development.IDE.Plugin.CodeAction.Rules
+        Development.IDE.Plugin.CodeAction.RuleTypes
         Development.IDE.Plugin.Completions.Logic
         Development.IDE.Plugin.Completions.Types
     ghc-options: -Wall -Wno-name-shadowing

src/Development/IDE/Core/Shake.hs

@@ -488,13 +488,13 @@ uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
 uses_ key files = do
     res <- uses key files
     case sequence res of
-        Nothing -> liftIO $ throwIO BadDependency
+        Nothing -> liftIO $ throwIO $ BadDependency (show key)
         Just v -> return v
 
 
 -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
 --   which short-circuits the rest of the action
-data BadDependency = BadDependency deriving Show
+data BadDependency = BadDependency String deriving Show
 instance Exception BadDependency
 
 isBadDependency :: SomeException -> Bool
@@ -659,12 +659,12 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
 needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
 needOnDisk k file = do
     successfull <- apply1 (QDisk k file)
-    liftIO $ unless successfull $ throwIO BadDependency
+    liftIO $ unless successfull $ throwIO $ BadDependency (show k)
 
 needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
 needOnDisks k files = do
     successfulls <- apply $ map (QDisk k) files
-    liftIO $ unless (and successfulls) $ throwIO BadDependency
+    liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
 
 toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
 toShakeValue = maybe ShakeNoCutoff

src/Development/IDE/GHC/Util.hs

@@ -9,6 +9,8 @@ module Development.IDE.GHC.Util(
     runGhcEnv,
     -- * GHC wrappers
     prettyPrint,
+    printRdrName,
+    printName,
     ParseResult(..), runParser,
     lookupPackageConfig,
     moduleImportPath,
@@ -98,6 +100,16 @@ runParser flags str parser = unP parser parseState
 prettyPrint :: Outputable a => a -> String
 prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
 
+-- | Pretty print a 'RdrName' wrapping operators in parens
+printRdrName :: RdrName -> String
+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)
+  where
+    rn = rdrNameOcc name
+
+-- | Pretty print a 'Name' wrapping operators in parens
+printName :: Name -> String
+printName = printRdrName . nameRdrName
+
 -- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
 --   pieces, but designed to be more efficient than a standard 'runGhc'.
 runGhcEnv :: HscEnv -> Ghc a -> IO a
@@ -151,6 +163,15 @@ instance Eq HscEnvEq where
 instance NFData HscEnvEq where
   rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
 
+instance Hashable HscEnvEq where
+  hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u
+
+-- Fake instance needed to persuade Shake to accept this type as a key.
+-- No harm done as ghcide never persists these keys currently
+instance Binary HscEnvEq where
+  put _ = error "not really"
+  get = error "not really"
+
 -- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
 readFileUtf8 :: FilePath -> IO T.Text
 readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f

src/Development/IDE/Plugin.hs

@@ -1,5 +1,5 @@
 
-module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where
+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules) where
 
 import Data.Default
 import Development.Shake
@@ -27,7 +27,10 @@ instance Monoid (Plugin c) where
 
 
 codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
-codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{
+codeActionPlugin = codeActionPluginWithRules mempty
+
+codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
+codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.codeActionHandler = withResponse RspCodeAction g
     }
     where

src/Development/IDE/Plugin/CodeAction.hs

@@ -8,7 +8,6 @@
 -- | Go to the definition of a variable.
 module Development.IDE.Plugin.CodeAction(plugin) where
 
-import Avail (AvailInfo(Avail), AvailInfo(AvailTC), availNames)
 import           Language.Haskell.LSP.Types
 import Control.Monad (join)
 import Development.IDE.Plugin
@@ -21,8 +20,11 @@ import Development.IDE.GHC.Error
 import Development.IDE.GHC.Util
 import Development.IDE.LSP.Server
 import Development.IDE.Plugin.CodeAction.PositionIndexed
+import Development.IDE.Plugin.CodeAction.RuleTypes
+import Development.IDE.Plugin.CodeAction.Rules
 import Development.IDE.Types.Location
 import Development.IDE.Types.Options
+import Development.Shake (Rules)
 import qualified Data.HashMap.Strict as Map
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.VFS
@@ -36,20 +38,18 @@ import Data.List.Extra
 import qualified Data.Text as T
 import Data.Tuple.Extra ((&&&))
 import HscTypes
-import OccName
 import Parser
-import RdrName
 import Text.Regex.TDFA ((=~), (=~~))
 import Text.Regex.TDFA.Text()
 import Outputable (ppr, showSDocUnsafe)
 import DynFlags (xFlags, FlagSpec(..))
 import GHC.LanguageExtensions.Type (Extension)
-import Data.IORef (readIORef)
-import Name (isDataConName, nameModule_maybe, nameOccName)
-import Packages (exposedModules, lookupPackage)
 
 plugin :: Plugin c
-plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens
+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
+
+rules :: Rules ()
+rules = rulePackageExports
 
 -- | Generate code actions.
 codeAction
@@ -65,15 +65,15 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
     let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
         mbFile = toNormalizedFilePath <$> uriToFilePath uri
-    (ideOptions, parsedModule, env) <- runAction state $
+    (ideOptions, parsedModule, join -> env) <- runAction state $
       (,,) <$> getIdeOptions
-           <*> getParsedModule `traverse` mbFile
-           <*> use_ GhcSession `traverse` mbFile
+            <*> getParsedModule `traverse` mbFile
+            <*> use GhcSession `traverse` mbFile
+    pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
     let dflags = hsc_dflags . hscEnv <$> env
-    eps <- traverse readIORef (hsc_EPS . hscEnv <$> env)
     pure $ Right
         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
-        | x <- xs, (title, tedit) <- suggestAction dflags eps ideOptions ( join parsedModule ) text x
+        | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ]
 
@@ -114,13 +114,13 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
 
 suggestAction
   :: Maybe DynFlags
-  -> Maybe ExternalPackageState
+  -> PackageExportsMap
   -> IdeOptions
   -> Maybe ParsedModule
   -> Maybe T.Text
   -> Diagnostic
   -> [(T.Text, [TextEdit])]
-suggestAction dflags eps ideOptions parsedModule text diag = concat
+suggestAction dflags packageExports ideOptions parsedModule text diag = concat
     [ suggestAddExtension diag
     , suggestExtendImport dflags text diag
     , suggestFillHole diag
@@ -132,7 +132,7 @@ suggestAction dflags eps ideOptions parsedModule text diag = concat
     ] ++ concat
     [  suggestNewDefinition ideOptions pm text diag
     ++ suggestRemoveRedundantImport pm text diag
-    ++ concat [suggestNewImport dflags eps pm diag | Just eps <- [eps], Just dflags <- [dflags]]
+    ++ suggestNewImport packageExports pm diag
     | Just pm <- [parsedModule]]
 
 
@@ -304,15 +304,10 @@ suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
             _ -> error "bug in srcspan parser"
           importLine = textInRange range c
         in [("Add " <> binding <> " to the import list of " <> mod
-        , [TextEdit range (addBindingToImportList (printRdrName name) importLine)])]
+        , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]
     | otherwise = []
 suggestExtendImport Nothing _ _ = []
 
-printRdrName :: RdrName -> T.Text
-printRdrName name = T.pack $ showSDocUnsafe $ parenSymOcc rn (ppr rn)
-  where
-    rn = rdrNameOcc name
-
 suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestFixConstructorImport _ Diagnostic{_range=_range,..}
     -- ‘Success’ is a data constructor of ‘Result’
@@ -353,8 +348,8 @@ suggestSignature _ _ = []
 
 -------------------------------------------------------------------------------------------------
 
-suggestNewImport :: DynFlags -> ExternalPackageState -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestNewImport dflags eps ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
+suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
   | msg <- unifySpaces _message
   , Just name <- extractNotInScopeName msg
   , Just insertLine <- case hsmodImports of
@@ -365,52 +360,36 @@ suggestNewImport dflags eps ParsedModule {pm_parsed_source = L _ HsModule {..}}
           RealSrcLoc s -> Just $ srcLocLine s
           _ -> Nothing
   , insertPos <- Position insertLine 0
-  , extendImportSuggestions <- -- Just [binding, mod, srcspan] <-
-    matchRegex msg
+  , extendImportSuggestions <- matchRegex msg
     "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
   = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
-    | imp <- constructNewImportSuggestions dflags eps name extendImportSuggestions
+    | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions
     ]
-suggestNewImport _ _ _ _ = []
-
-constructNewImportSuggestions :: DynFlags -> ExternalPackageState -> NotInScope -> Maybe [T.Text] -> [T.Text]
-constructNewImportSuggestions dflags eps thingMissing notTheseModules = nubOrd
-      [ case qual of
-          Nothing -> "import " <> modName <> " (" <> importWhat candidate avail <> ")"
-          Just q  -> "import qualified " <> modName <> " as " <> q
-        | item <- items,
-          avail <- tyThingAvailInfo item,
-          canUseAvail thingMissing avail,
-          candidate <- availNames avail,
-          canUseName thingMissing candidate,
-          occNameString (nameOccName candidate) == T.unpack name,
-          Just m <- [nameModule_maybe candidate],
-          Just package <- [lookupPackage dflags (moduleUnitId m)],
-          moduleName m `elem` map fst (exposedModules package),
-          let modName = T.pack $ moduleNameString $ moduleName m,
-          modName `notElem` fromMaybe [] notTheseModules
-      ]
-    where
-        (qual, name) = case T.splitOn "." (notInScope thingMissing) of
-            [n]      -> (Nothing, n)
-            segments -> (Just (T.concat $ init segments), last segments)
-        items = typeEnvElts $ eps_PTE eps
-        importWhat this (AvailTC parent _ _)
-          -- "Maybe(Just)"
-          | this /= parent
-          = T.pack (occNameString (nameOccName parent)) <>
-            "(" <> printName this <> ")"
-        importWhat this _ = printName this
-
-        printName = printRdrName . nameRdrName
-
-canUseAvail :: NotInScope -> AvailInfo -> Bool
-canUseAvail NotInScopeDataConstructor{} Avail{} = False
-canUseAvail _ _ = True
-
-canUseName :: NotInScope -> Name -> Bool
-canUseName NotInScopeDataConstructor{} = isDataConName
-canUseName _ = const True
+suggestNewImport _ _ _ = []
+
+constructNewImportSuggestions
+  :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]
+constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd
+  [ renderNewImport identInfo m
+  | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap
+  , canUseIdent thingMissing identInfo
+  , m `notElem` fromMaybe [] notTheseModules
+  ]
+ where
+  renderNewImport identInfo m
+    | Just q <- qual = "import qualified " <> m <> " as " <> q
+    | otherwise      = "import " <> m <> " (" <> importWhat identInfo <> ")"
+
+  (qual, name) = case T.splitOn "." (notInScope thingMissing) of
+    [n]      -> (Nothing, n)
+    segments -> (Just (T.concat $ init segments), last segments)
+  importWhat IdentInfo {parent, rendered}
+    | Just p <- parent = p <> "(" <> rendered <> ")"
+    | otherwise        = rendered
+
+canUseIdent :: NotInScope -> IdentInfo -> Bool
+canUseIdent NotInScopeDataConstructor{} = isDatacon
+canUseIdent _                           = const True
 
 data NotInScope
     = NotInScopeDataConstructor T.Text
@@ -427,6 +406,8 @@ extractNotInScopeName :: T.Text -> Maybe NotInScope
 extractNotInScopeName x
   | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"
   = Just $ NotInScopeDataConstructor name
+  | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"
+  = Just $ NotInScopeDataConstructor name
   | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
   = Just $ NotInScopeTypeConstructorOrClass name
   | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

src/Development/IDE/Plugin/CodeAction/RuleTypes.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE TypeFamilies #-}
+module Development.IDE.Plugin.CodeAction.RuleTypes
+    (PackageExports(..), PackageExportsMap
+    ,IdentInfo(..)
+    ,mkIdentInfos
+    ) where
+
+import Avail (AvailInfo(..))
+import Data.Hashable (Hashable)
+import Control.DeepSeq (NFData)
+import Data.Binary (Binary)
+import Data.Text (pack, Text)
+import Development.IDE.GHC.Util
+import Development.Shake (RuleResult)
+import Data.HashMap.Strict (HashMap)
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import Name
+import FieldLabel (flSelector)
+
+type Identifier = Text
+type ModuleName = Text
+
+data IdentInfo = IdentInfo
+    { name :: !Identifier
+    , rendered :: Text
+    , parent :: !(Maybe Text)
+    , isDatacon :: !Bool
+    }
+    deriving (Eq, Generic, Show)
+
+instance NFData IdentInfo
+
+mkIdentInfos :: AvailInfo -> [IdentInfo]
+mkIdentInfos (Avail n) =
+    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]
+mkIdentInfos (AvailTC parent (n:nn) flds)
+    -- Following the GHC convention that parent == n if parent is exported
+    | n == parent
+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True
+        | n <- nn ++ map flSelector flds
+      ] ++
+      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]
+    where
+        parentP = pack $ prettyPrint parent
+
+mkIdentInfos (AvailTC _ nn flds)
+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True
+        | n <- nn ++ map flSelector flds
+      ]
+
+-- Rule type for caching Package Exports
+type instance RuleResult PackageExports = PackageExportsMap
+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]
+
+newtype PackageExports = PackageExports HscEnvEq
+    deriving (Eq, Show, Typeable, Generic)
+
+instance Hashable PackageExports
+instance NFData   PackageExports
+instance Binary   PackageExports