From e0b5be3de3226772abe3b48706fb5945cac9d784 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 28 Sep 2022 16:46:29 +0530 Subject: [PATCH 1/4] improve memory usage of ExportsMap Storing rendered names as `Text`, especially for parents, adds a lot of duplication to the ExportsMap. Instead we store the `OccName`s directly, which have hash-consed symbols due stored as `FastStrings` and render it out on demand (which is just decoding the UTF-8 FastString to UTF-16 text for text <2.0, and essentially free on text >2.0). --- ghcide/src/Development/IDE/GHC/Compat.hs | 4 + .../IDE/Plugin/Completions/Logic.hs | 19 +++-- ghcide/src/Development/IDE/Types/Exports.hs | 82 ++++++++++--------- .../src/Development/IDE/Plugin/CodeAction.hs | 21 +++-- 4 files changed, 69 insertions(+), 57 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index b14b62a89a..35b6e13442 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -43,6 +43,8 @@ module Development.IDE.GHC.Compat( #endif FastStringCompat, + bytesFS, + mkFastStringByteString, nodeInfo', getNodeIds, sourceNodeInfo, @@ -206,6 +208,7 @@ import VarEnv (emptyInScopeSet, #endif #if MIN_VERSION_ghc(9,0,0) +import GHC.Data.FastString import GHC.Core import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) @@ -224,6 +227,7 @@ import GHC.Iface.Make (mkIfaceExports) import qualified GHC.SysTools.Tasks as SysTools import qualified GHC.Types.Avail as Avail #else +import FastString import qualified Avail import DynFlags hiding (ExposePackage) import HscTypes diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index c93a9d23e4..223ecb77f4 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -287,25 +287,26 @@ mkExtCompl label = fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem -fromIdentInfo doc IdentInfo{..} q = CI +fromIdentInfo doc id@IdentInfo{..} q = CI { compKind= occNameToComKind name - , insertText=rendered - , provenance = DefinedIn moduleNameText - , label=rendered - , typeText = Nothing + , insertText=rend + , provenance = DefinedIn mod + , label=rend , isInfix=Nothing - , isTypeCompl= not isDatacon && isUpper (T.head rendered) + , isTypeCompl= not (isDatacon id) && isUpper (T.head rend) , additionalTextEdits= Just $ ExtendImport { doc, - thingParent = parent, - importName = moduleNameText, + thingParent = occNameText <$> parent, + importName = mod, importQual = q, - newThing = rendered + newThing = rend } , nameDetails = Nothing , isLocalCompletion = False } + where rend = rendered id + mod = moduleNameText id cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports = diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 8d75c12f1d..d489793934 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -5,6 +5,10 @@ module Development.IDE.Types.Exports ( IdentInfo(..), ExportsMap(..), + rendered, + moduleNameText, + occNameText, + isDatacon, createExportsMap, createExportsMapMg, createExportsMapTc, @@ -24,6 +28,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Data.List (foldl', isSuffixOf) import Data.Text (Text, pack) +import Data.Text.Encoding (decodeUtf8) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util @@ -61,55 +66,63 @@ instance Monoid ExportsMap where type IdentifierText = Text type ModuleNameText = Text + +rendered :: IdentInfo -> IdentifierText +rendered = occNameText . name + +-- | Render an identifier as imported or exported style. +-- TODO: pattern synonymoccNameText :: OccName -> Text +occNameText :: OccName -> IdentifierText +occNameText name + | isTcOcc name && isSymOcc name = "type " <> renderOcc + | otherwise = renderOcc + where + renderOcc = decodeUtf8 . bytesFS . occNameFS $ name + +moduleNameText :: IdentInfo -> ModuleNameText +moduleNameText = moduleNameText' . identModuleName + +moduleNameText' :: ModuleName -> ModuleNameText +moduleNameText' = decodeUtf8 . bytesFS . moduleNameFS + data IdentInfo = IdentInfo - { name :: !OccName - , rendered :: Text - , parent :: !(Maybe Text) - , isDatacon :: !Bool - , moduleNameText :: !Text + { name :: !OccName + , parent :: !(Maybe OccName) + , identModuleName :: !ModuleName } deriving (Generic, Show) deriving anyclass Hashable +isDatacon :: IdentInfo -> Bool +isDatacon = isDataOcc . name + instance Eq IdentInfo where a == b = name a == name b && parent a == parent b - && isDatacon a == isDatacon b - && moduleNameText a == moduleNameText b + && identModuleName a == identModuleName b instance NFData IdentInfo where rnf IdentInfo{..} = -- deliberately skip the rendered field - rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText - --- | Render an identifier as imported or exported style. --- TODO: pattern synonym -renderIEWrapped :: Name -> Text -renderIEWrapped n - | isTcOcc occ && isSymOcc occ = "type " <> pack (printName n) - | otherwise = pack $ printName n - where - occ = occName n + rnf name `seq` rnf parent `seq` rnf identModuleName -mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] +mkIdentInfos :: ModuleName -> AvailInfo -> [IdentInfo] mkIdentInfos mod (AvailName n) = - [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] + [IdentInfo (nameOccName n) Nothing mod] mkIdentInfos mod (AvailFL fl) = - [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] + [IdentInfo (nameOccName n) Nothing mod] where n = flSelector fl mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod + = [ IdentInfo (nameOccName n) (Just $! nameOccName parent) mod | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] - where - parentP = pack $ printName parent + [ IdentInfo (nameOccName n) Nothing mod] mkIdentInfos mod (AvailTC _ nn flds) - = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod + = [ IdentInfo (nameOccName n) Nothing mod | n <- nn ++ map flSelector flds ] @@ -160,25 +173,20 @@ createExportsMapHieDb withHieDb = do mods <- withHieDb getAllIndexedMods idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m - mText = pack $ moduleNameString mn - fmap (wrap . unwrap mText) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) + fmap (wrap . unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) let exportsMap = Map.fromListWith (<>) (concat idents) - return $ ExportsMap exportsMap $ buildModuleExportMap (concat idents) + return $! ExportsMap exportsMap $ buildModuleExportMap (concat idents) where wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) -- unwrap :: ExportRow -> IdentInfo - unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m - where - n = pack (occNameString exportName) - p = pack . occNameString <$> exportParent + unwrap m ExportRow{..} = IdentInfo exportName exportParent m unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])] unpackAvail mn - | nonInternalModules mn = map f . mkIdentInfos mod + | nonInternalModules mn = map f . mkIdentInfos mn | otherwise = const [] where - !mod = pack $ moduleNameString mn - f id@IdentInfo {..} = (printOutputable name, moduleNameText,[id]) + f id@IdentInfo {..} = (printOutputable name, moduleNameText id,[id]) identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo) @@ -198,9 +206,9 @@ buildModuleExportMapFrom modIfaces = do extractModuleExports :: ModIface -> (Text, HashSet IdentInfo) extractModuleExports modIFace = do - let modName = pack $ moduleNameString $ moduleName $ mi_module modIFace + let modName = moduleName $ mi_module modIFace let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace - (modName, functionSet) + (moduleNameText' modName, functionSet) sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo) sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 9052555388..1e21b5ba41 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -37,6 +37,7 @@ import Data.Maybe import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Text.Utf16.Rope as Rope import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes @@ -986,11 +987,9 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ -- fallback to using GHC suggestion even though it is not always correct | otherwise = Just IdentInfo - { name = mkVarOcc $ T.unpack binding - , rendered = binding + { name = mkVarOccFS $ mkFastStringByteString $ T.encodeUtf8 binding , parent = Nothing - , isDatacon = False - , moduleNameText = mod} + , identModuleName = mkModuleNameFS $ mkFastStringByteString $ T.encodeUtf8 mod} #endif data HidingMode @@ -1390,18 +1389,18 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos _message "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", idents <- - maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $ + maybe [] (Set.toList . Set.filter (\x -> fmap occNameText (parent x) == Just className)) $ Map.lookup methodName $ getExportsMap packageExportsMap = mconcat $ suggest <$> idents | otherwise = [] where - suggest identInfo@IdentInfo {moduleNameText} + suggest identInfo | importStyle <- NE.toList $ importStyles identInfo, - mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleNameText) = + mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleText) = case mImportDecl of -- extend Just decl -> - [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText, + [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleText, quickFixImportKind' "extend" style, [Right $ uncurry extendImport (unImportStyle style) decl] ) @@ -1412,12 +1411,13 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos | Just (range, indent) <- newImportInsertRange ps fileContents -> (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$> - [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False) + [ (quickFixImportKind' "new" style, newUnqualImport moduleText rendered False) | style <- importStyle, let rendered = renderImportStyle style ] - <> [(quickFixImportKind "new.all", newImportAll moduleNameText)] + <> [(quickFixImportKind "new.all", newImportAll moduleText)] | otherwise -> [] + where moduleText = moduleNameText identInfo #endif suggestNewImport :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] @@ -1911,4 +1911,3 @@ matchRegExMultipleImports message = do _ -> Nothing imps <- regExImports imports return (binding, imps) - From 6eb6570ac6cffe36e8a45ce08dae5babf72088e0 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 28 Sep 2022 23:12:11 +0530 Subject: [PATCH 2/4] export map improvements --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../src/Development/IDE/Plugin/Completions.hs | 2 +- .../IDE/Plugin/Completions/Logic.hs | 10 +- ghcide/src/Development/IDE/Types/Exports.hs | 144 ++++++++++-------- 4 files changed, 85 insertions(+), 73 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 00655b5a4d..5b6aea20ec 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -658,7 +658,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) - readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) + readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index bbfa7dc6c3..dcb85a9734 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -186,7 +186,7 @@ getCompletionsLSP ide plId let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap let moduleExports = getModuleExportsMap exportsMap - exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap + exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . occEnvElts . getExportsMap $ exportsMap exportsCompls = mempty{anyQualCompls = exportsCompItems} let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 223ecb77f4..c898ab0cac 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -529,7 +529,7 @@ getCompletions -> PosPrefixInfo -> ClientCapabilities -> CompletionsConfig - -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) + -> ModuleNameEnv (HashSet.HashSet IdentInfo) -> Uri -> IO [Scored CompletionItem] getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} @@ -661,10 +661,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, && (List.length (words (T.unpack fullLine)) >= 2) && "(" `isInfixOf` T.unpack fullLine -> do - let moduleName = T.pack $ words (T.unpack fullLine) !! 1 - funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap - funs = map (show . name) $ HashSet.toList funcs - return $ filterModuleExports moduleName $ map T.pack funs + let moduleName = words (T.unpack fullLine) !! 1 + funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName + funs = map (renderOcc . name) $ HashSet.toList funcs + return $ filterModuleExports (T.pack moduleName) funs | "import " `T.isPrefixOf` fullLine -> return filtImportCompls -- we leave this condition here to avoid duplications and return empty list diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index d489793934..4d6f3f99fa 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -8,27 +8,31 @@ module Development.IDE.Types.Exports rendered, moduleNameText, occNameText, + renderOcc, + mkTypeOcc, + mkVarOrDataOcc, isDatacon, createExportsMap, createExportsMapMg, - createExportsMapTc, buildModuleExportMapFrom, createExportsMapHieDb, size, + exportsMapSize, updateExportsMapMg ) where import Control.DeepSeq (NFData (..)) import Control.Monad import Data.Bifunctor (Bifunctor (second)) +import Data.Char (isUpper) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap, elems) import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Data.List (foldl', isSuffixOf) -import Data.Text (Text, pack) -import Data.Text.Encoding (decodeUtf8) +import Data.Text (Text, uncons) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util @@ -37,52 +41,72 @@ import HieDb data ExportsMap = ExportsMap - { getExportsMap :: !(HashMap IdentifierText (HashSet IdentInfo)) - , getModuleExportsMap :: !(HashMap ModuleNameText (HashSet IdentInfo)) + { getExportsMap :: !(OccEnv (HashSet IdentInfo)) + , getModuleExportsMap :: !(ModuleNameEnv (HashSet IdentInfo)) } - deriving (Show) - -deleteEntriesForModule :: ModuleNameText -> ExportsMap -> ExportsMap -deleteEntriesForModule m em = ExportsMap - { getExportsMap = - let moduleIds = Map.lookupDefault mempty m (getModuleExportsMap em) - in deleteAll - (rendered <$> Set.toList moduleIds) - (getExportsMap em) - , getModuleExportsMap = Map.delete m (getModuleExportsMap em) - } - where - deleteAll keys map = foldr Map.delete map keys + +instance Show ExportsMap where + show (ExportsMap occs mods) = + unwords [ "ExportsMap { getExportsMap =" + , printWithoutUniques $ mapOccEnv (text . show) occs + , "getModuleExportsMap =" + , printWithoutUniques $ mapUFM (text . show) mods + , "}" + ] + +-- | `updateExportsMap old new` results in an export map containing +-- the union of old and new, but with all the module entries new overriding +-- those in old. +updateExportsMap :: ExportsMap -> ExportsMap -> ExportsMap +updateExportsMap old new = ExportsMap + { getExportsMap = delListFromOccEnv (getExportsMap old) old_occs `plusOccEnv` getExportsMap new -- plusOccEnv is right biased + , getModuleExportsMap = (getModuleExportsMap old) `plusUFM` (getModuleExportsMap new) -- plusUFM is right biased + } + where old_occs = concat [map name $ Set.toList (lookupWithDefaultUFM_Directly (getModuleExportsMap old) mempty m_uniq) + | m_uniq <- nonDetKeysUFM (getModuleExportsMap new)] size :: ExportsMap -> Int -size = sum . map length . elems . getExportsMap +size = sum . map (Set.size) . occEnvElts . getExportsMap -instance Semigroup ExportsMap where - ExportsMap a b <> ExportsMap c d = ExportsMap (Map.unionWith (<>) a c) (Map.unionWith (<>) b d) +mkVarOrDataOcc :: Text -> OccName +mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t + where + mkOcc + | Just (c,_) <- uncons t + , c == ':' || isUpper c = mkDataOccFS + | otherwise = mkVarOccFS -instance Monoid ExportsMap where - mempty = ExportsMap Map.empty Map.empty +mkTypeOcc :: Text -> OccName +mkTypeOcc t = mkTcOccFS $ mkFastStringByteString $ encodeUtf8 t -type IdentifierText = Text -type ModuleNameText = Text +exportsMapSize :: ExportsMap -> Int +exportsMapSize = foldOccEnv (\_ x -> x+1) 0 . getExportsMap +instance Semigroup ExportsMap where + ExportsMap a b <> ExportsMap c d = ExportsMap (plusOccEnv_C (<>) a c) (plusUFM_C (<>) b d) -rendered :: IdentInfo -> IdentifierText +instance Monoid ExportsMap where + mempty = ExportsMap emptyOccEnv emptyUFM + +rendered :: IdentInfo -> Text rendered = occNameText . name -- | Render an identifier as imported or exported style. -- TODO: pattern synonymoccNameText :: OccName -> Text -occNameText :: OccName -> IdentifierText +occNameText :: OccName -> Text occNameText name - | isTcOcc name && isSymOcc name = "type " <> renderOcc - | otherwise = renderOcc + | isTcOcc name && isSymOcc name = "type " <> renderedOcc + | otherwise = renderedOcc where - renderOcc = decodeUtf8 . bytesFS . occNameFS $ name + renderedOcc = renderOcc name + +renderOcc :: OccName -> Text +renderOcc = decodeUtf8 . bytesFS . occNameFS -moduleNameText :: IdentInfo -> ModuleNameText +moduleNameText :: IdentInfo -> Text moduleNameText = moduleNameText' . identModuleName -moduleNameText' :: ModuleName -> ModuleNameText +moduleNameText' :: ModuleName -> Text moduleNameText' = decodeUtf8 . bytesFS . moduleNameFS data IdentInfo = IdentInfo @@ -129,39 +153,27 @@ mkIdentInfos mod (AvailTC _ nn flds) createExportsMap :: [ModIface] -> ExportsMap createExportsMap modIface = do let exportList = concatMap doOne modIface - let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList + let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList where doOne modIFace = do let getModDetails = unpackAvail $ moduleName $ mi_module modIFace - concatMap (fmap (second Set.fromList) . getModDetails) (mi_exports modIFace) + concatMap (getModDetails) (mi_exports modIFace) createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do let exportList = concatMap doOne modGuts - let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList + let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList where doOne mi = do let getModuleName = moduleName $ mg_module mi - concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi) + concatMap (unpackAvail getModuleName) (mg_exports mi) updateExportsMapMg :: [ModGuts] -> ExportsMap -> ExportsMap -updateExportsMapMg modGuts old = old' <> new +updateExportsMapMg modGuts old = updateExportsMap old new where new = createExportsMapMg modGuts - old' = deleteAll old (Map.keys $ getModuleExportsMap new) - deleteAll = foldl' (flip deleteEntriesForModule) - -createExportsMapTc :: [TcGblEnv] -> ExportsMap -createExportsMapTc modIface = do - let exportList = concatMap doOne modIface - let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList - ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList - where - doOne mi = do - let getModuleName = moduleName $ tcg_mod mi - concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (tcg_exports mi) nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString @@ -171,44 +183,44 @@ type WithHieDb = forall a. (HieDb -> IO a) -> IO a createExportsMapHieDb :: WithHieDb -> IO ExportsMap createExportsMapHieDb withHieDb = do mods <- withHieDb getAllIndexedMods - idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do + idents' <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m - fmap (wrap . unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) - let exportsMap = Map.fromListWith (<>) (concat idents) - return $! ExportsMap exportsMap $ buildModuleExportMap (concat idents) + fmap (unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) + let idents = concat idents' + let exportsMap = mkOccEnv_C (<>) (keyWith name idents) + return $! ExportsMap exportsMap $ buildModuleExportMap (keyWith identModuleName idents) where - wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) - -- unwrap :: ExportRow -> IdentInfo unwrap m ExportRow{..} = IdentInfo exportName exportParent m + keyWith f xs = [(f x, Set.singleton x) | x <- xs] -unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])] +unpackAvail :: ModuleName -> IfaceExport -> [(OccName, ModuleName, HashSet IdentInfo)] unpackAvail mn | nonInternalModules mn = map f . mkIdentInfos mn | otherwise = const [] where - f id@IdentInfo {..} = (printOutputable name, moduleNameText id,[id]) + f id@IdentInfo {..} = (name, mn, Set.singleton id) -identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo) +identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo) identInfoToKeyVal identInfo = - (moduleNameText identInfo, identInfo) + (identModuleName identInfo, identInfo) -buildModuleExportMap:: [(Text, HashSet IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo) +buildModuleExportMap:: [(ModuleName, HashSet IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMap exportsMap = do let lst = concatMap (Set.toList. snd) exportsMap let lstThree = map identInfoToKeyVal lst sortAndGroup lstThree -buildModuleExportMapFrom:: [ModIface] -> Map.HashMap Text (HashSet IdentInfo) +buildModuleExportMapFrom:: [ModIface] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMapFrom modIfaces = do let exports = map extractModuleExports modIfaces - Map.fromListWith (<>) exports + listToUFM_C (<>) exports -extractModuleExports :: ModIface -> (Text, HashSet IdentInfo) +extractModuleExports :: ModIface -> (ModuleName, HashSet IdentInfo) extractModuleExports modIFace = do let modName = moduleName $ mi_module modIFace let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace - (moduleNameText' modName, functionSet) + (modName, functionSet) -sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo) -sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs] +sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) +sortAndGroup assocs = listToUFM_C (<>) [(k, Set.fromList [v]) | (k, v) <- assocs] From 64f76e375c66ab02a1893a564730d16c085ec10d Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 28 Sep 2022 23:27:58 +0530 Subject: [PATCH 3/4] export map improvements --- ghcide/src/Development/IDE/Types/Exports.hs | 11 +++++++---- .../src/Development/IDE/Plugin/CodeAction.hs | 14 ++++++++------ 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 4d6f3f99fa..00a9452172 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -21,7 +21,7 @@ module Development.IDE.Types.Exports updateExportsMapMg ) where -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData (..), force, ($!!)) import Control.Monad import Data.Bifunctor (Bifunctor (second)) import Data.Char (isUpper) @@ -45,6 +45,9 @@ data ExportsMap = ExportsMap , getModuleExportsMap :: !(ModuleNameEnv (HashSet IdentInfo)) } +instance NFData ExportsMap where + rnf (ExportsMap a b) = foldOccEnv (\a b -> rnf a `seq` b) (seqEltsUFM rnf b) a + instance Show ExportsMap where show (ExportsMap occs mods) = unwords [ "ExportsMap { getExportsMap =" @@ -154,7 +157,7 @@ createExportsMap :: [ModIface] -> ExportsMap createExportsMap modIface = do let exportList = concatMap doOne modIface let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList - ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList + force $ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList -- UFM is lazy, so need to seq where doOne modIFace = do let getModDetails = unpackAvail $ moduleName $ mi_module modIFace @@ -164,7 +167,7 @@ createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do let exportList = concatMap doOne modGuts let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList - ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList + force $ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList -- UFM is lazy, so need to seq where doOne mi = do let getModuleName = moduleName $ mg_module mi @@ -188,7 +191,7 @@ createExportsMapHieDb withHieDb = do fmap (unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) let idents = concat idents' let exportsMap = mkOccEnv_C (<>) (keyWith name idents) - return $! ExportsMap exportsMap $ buildModuleExportMap (keyWith identModuleName idents) + return $!! ExportsMap exportsMap $ buildModuleExportMap (keyWith identModuleName idents) -- UFM is lazy so need to seq where unwrap m ExportRow{..} = IdentInfo exportName exportParent m keyWith f xs = [(f x, Set.singleton x) | x <- xs] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 1e21b5ba41..cd5b8841fc 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -975,19 +975,21 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ ] | otherwise = [] lookupExportMap binding mod - | Just match <- Map.lookup binding (getExportsMap exportsMap) + | let em = getExportsMap exportsMap + match1 = lookupOccEnv em (mkVarOrDataOcc binding) + match2 = lookupOccEnv em (mkTypeOcc binding) + , Just match <- match1 <> match2 -- Only for the situation that data constructor name is same as type constructor name, -- let ident with parent be in front of the one without. , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch - , (not . null) idents -- Ensure fallback while `idents` is empty - , ident <- head idents + , (ident:_) <- idents -- Ensure fallback while `idents` is empty = Just ident -- fallback to using GHC suggestion even though it is not always correct | otherwise = Just IdentInfo - { name = mkVarOccFS $ mkFastStringByteString $ T.encodeUtf8 binding + { name = mkVarOrDataOcc binding , parent = Nothing , identModuleName = mkModuleNameFS $ mkFastStringByteString $ T.encodeUtf8 mod} #endif @@ -1390,7 +1392,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’", idents <- maybe [] (Set.toList . Set.filter (\x -> fmap occNameText (parent x) == Just className)) $ - Map.lookup methodName $ getExportsMap packageExportsMap = + lookupOccEnv (getExportsMap packageExportsMap) (mkVarOrDataOcc methodName) = mconcat $ suggest <$> idents | otherwise = [] where @@ -1445,7 +1447,7 @@ constructNewImportSuggestions constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdBy simpleCompareImportSuggestion [ suggestion | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] -- strip away qualified module names from the unknown name - , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) -- look up the modified unknown name in the export map + , identInfo <- maybe [] Set.toList $ (lookupOccEnv (getExportsMap exportsMap) (mkVarOrDataOcc name)) <> (lookupOccEnv (getExportsMap exportsMap) (mkTypeOcc name)) -- look up the modified unknown name in the export map , canUseIdent thingMissing identInfo -- check if the identifier information retrieved can be used , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules -- check if the module of the identifier is allowed , suggestion <- renderNewImport identInfo -- creates a list of import suggestions for the retrieved identifier information From 7a4e1a9f9aceef329f0230c805bf4ef8e306b57d Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 12 Dec 2022 16:58:52 +0530 Subject: [PATCH 4/4] fixes --- ghcide/src/Development/IDE/GHC/Compat.hs | 7 +++++++ ghcide/src/Development/IDE/Plugin/Completions.hs | 2 +- .../Development/IDE/Plugin/Completions/Logic.hs | 1 + ghcide/src/Development/IDE/Types/Exports.hs | 5 +++-- .../Development/IDE/Plugin/Plugins/ImportUtils.hs | 14 ++++++++------ plugins/hls-refactor-plugin/test/Main.hs | 2 +- 6 files changed, 21 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 35b6e13442..bbc4c1a585 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -55,6 +55,8 @@ module Development.IDE.GHC.Compat( mkAstNode, combineRealSrcSpans, + nonDetOccEnvElts, + isQualifiedImport, GhcVersion(..), ghcVersion, @@ -268,6 +270,11 @@ import GHC.Types.Error import GHC.Driver.Config.Stg.Pipeline #endif +#if !MIN_VERSION_ghc(9,3,0) +nonDetOccEnvElts :: OccEnv a -> [a] +nonDetOccEnvElts = occEnvElts +#endif + type ModIfaceAnnotation = Annotation #if MIN_VERSION_ghc(9,3,0) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index dcb85a9734..0442acef14 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -186,7 +186,7 @@ getCompletionsLSP ide plId let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap let moduleExports = getModuleExportsMap exportsMap - exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . occEnvElts . getExportsMap $ exportsMap + exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . nonDetOccEnvElts . getExportsMap $ exportsMap exportsCompls = mempty{anyQualCompls = exportsCompItems} let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index c898ab0cac..92a4ea0320 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -292,6 +292,7 @@ fromIdentInfo doc id@IdentInfo{..} q = CI , insertText=rend , provenance = DefinedIn mod , label=rend + , typeText = Nothing , isInfix=Nothing , isTypeCompl= not (isDatacon id) && isUpper (T.head rend) , additionalTextEdits= Just $ diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 00a9452172..d61105801c 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -69,7 +69,7 @@ updateExportsMap old new = ExportsMap | m_uniq <- nonDetKeysUFM (getModuleExportsMap new)] size :: ExportsMap -> Int -size = sum . map (Set.size) . occEnvElts . getExportsMap +size = sum . map (Set.size) . nonDetOccEnvElts . getExportsMap mkVarOrDataOcc :: Text -> OccName mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t @@ -98,7 +98,8 @@ rendered = occNameText . name -- TODO: pattern synonymoccNameText :: OccName -> Text occNameText :: OccName -> Text occNameText name - | isTcOcc name && isSymOcc name = "type " <> renderedOcc + | isSymOcc name = "(" <> renderedOcc <> ")" + | isTcOcc name && isSymOcc name = "type (" <> renderedOcc <> ")" | otherwise = renderedOcc where renderedOcc = renderOcc name diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs index 81014c0180..e192fba98c 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs @@ -10,7 +10,7 @@ module Development.IDE.Plugin.Plugins.ImportUtils import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Text as T import Development.IDE.Plugin.CodeAction.ExactPrint (wildCardSymbol) -import Development.IDE.Types.Exports (IdentInfo (..)) +import Development.IDE.Types.Exports import Language.LSP.Types (CodeActionKind (..)) -- | Possible import styles for an 'IdentInfo'. @@ -49,16 +49,18 @@ data ImportStyle deriving Show importStyles :: IdentInfo -> NonEmpty ImportStyle -importStyles IdentInfo {parent, rendered, isDatacon} - | Just p <- parent +importStyles i@(IdentInfo {parent}) + | Just p <- pr -- Constructors always have to be imported via their parent data type, but -- methods and associated type/data families can also be imported as -- top-level exports. - = ImportViaParent rendered p - :| [ImportTopLevel rendered | not isDatacon] + = ImportViaParent rend p + :| [ImportTopLevel rend | not (isDatacon i)] <> [ImportAllConstructors p] | otherwise - = ImportTopLevel rendered :| [] + = ImportTopLevel rend :| [] + where rend = rendered i + pr = occNameText <$> parent -- | Used for adding new imports renderImportStyle :: ImportStyle -> T.Text diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 9a461c61f5..1177b77d4c 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -1675,7 +1675,7 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = (&) [] id" [] "import Data.Function ((&))" , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" - , test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))" + , test True [] "f :: a ~~ b" [] "import Data.Type.Equality ((~~))" , test True ["qualified Data.Text as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"