Skip to content

Commit 8a176df

Browse files
wz1000wz1000
committed
export map improvements
1 parent b6e819b commit 8a176df

File tree

4 files changed

+85
-73
lines changed

4 files changed

+85
-73
lines changed

‎ghcide/src/Development/IDE/Core/Shake.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -658,7 +658,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
658658
let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
659659
readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)
660660
readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
661-
readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras)
661+
readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras)
662662
readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
663663
readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb
664664

‎ghcide/src/Development/IDE/Plugin/Completions.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -186,7 +186,7 @@ getCompletionsLSP ide plId
186186
let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap
187187

188188
let moduleExports = getModuleExportsMap exportsMap
189-
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap
189+
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . occEnvElts . getExportsMap $ exportsMap
190190
exportsCompls = mempty{anyQualCompls = exportsCompItems}
191191
let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
192192

‎ghcide/src/Development/IDE/Plugin/Completions/Logic.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -529,7 +529,7 @@ getCompletions
529529
-> PosPrefixInfo
530530
-> ClientCapabilities
531531
-> CompletionsConfig
532-
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
532+
-> ModuleNameEnv (HashSet.HashSet IdentInfo)
533533
-> Uri
534534
-> IO [Scored CompletionItem]
535535
getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
@@ -661,10 +661,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
661661
&& (List.length (words (T.unpack fullLine)) >= 2)
662662
&& "(" `isInfixOf` T.unpack fullLine
663663
-> do
664-
let moduleName = T.pack $ words (T.unpack fullLine) !! 1
665-
funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap
666-
funs = map (show . name) $ HashSet.toList funcs
667-
return $ filterModuleExports moduleName $ map T.pack funs
664+
let moduleName = words (T.unpack fullLine) !! 1
665+
funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName
666+
funs = map (renderOcc . name) $ HashSet.toList funcs
667+
return $ filterModuleExports (T.pack moduleName) funs
668668
| "import " `T.isPrefixOf` fullLine
669669
-> return filtImportCompls
670670
-- we leave this condition here to avoid duplications and return empty list

‎ghcide/src/Development/IDE/Types/Exports.hs‎

Lines changed: 78 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -8,27 +8,31 @@ module Development.IDE.Types.Exports
88
rendered,
99
moduleNameText,
1010
occNameText,
11+
renderOcc,
12+
mkTypeOcc,
13+
mkVarOrDataOcc,
1114
isDatacon,
1215
createExportsMap,
1316
createExportsMapMg,
14-
createExportsMapTc,
1517
buildModuleExportMapFrom,
1618
createExportsMapHieDb,
1719
size,
20+
exportsMapSize,
1821
updateExportsMapMg
1922
) where
2023

2124
import Control.DeepSeq (NFData (..))
2225
import Control.Monad
2326
import Data.Bifunctor (Bifunctor (second))
27+
import Data.Char (isUpper)
2428
import Data.Hashable (Hashable)
2529
import Data.HashMap.Strict (HashMap, elems)
2630
import qualified Data.HashMap.Strict as Map
2731
import Data.HashSet (HashSet)
2832
import qualified Data.HashSet as Set
2933
import Data.List (foldl', isSuffixOf)
30-
import Data.Text (Text, pack)
31-
import Data.Text.Encoding (decodeUtf8)
34+
import Data.Text (Text, uncons)
35+
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3236
import Development.IDE.GHC.Compat
3337
import Development.IDE.GHC.Orphans ()
3438
import Development.IDE.GHC.Util
@@ -37,52 +41,72 @@ import HieDb
3741

3842

3943
data ExportsMap = ExportsMap
40-
{ getExportsMap :: !(HashMap IdentifierText (HashSet IdentInfo))
41-
, getModuleExportsMap :: !(HashMap ModuleNameText (HashSet IdentInfo))
44+
{ getExportsMap :: !(OccEnv (HashSet IdentInfo))
45+
, getModuleExportsMap :: !(ModuleNameEnv (HashSet IdentInfo))
4246
}
43-
deriving (Show)
44-
45-
deleteEntriesForModule :: ModuleNameText -> ExportsMap -> ExportsMap
46-
deleteEntriesForModule m em = ExportsMap
47-
{ getExportsMap =
48-
let moduleIds = Map.lookupDefault mempty m (getModuleExportsMap em)
49-
in deleteAll
50-
(rendered <$> Set.toList moduleIds)
51-
(getExportsMap em)
52-
, getModuleExportsMap = Map.delete m (getModuleExportsMap em)
53-
}
54-
where
55-
deleteAll keys map = foldr Map.delete map keys
47+
48+
instance Show ExportsMap where
49+
show (ExportsMap occs mods) =
50+
unwords [ "ExportsMap { getExportsMap ="
51+
, printWithoutUniques $ mapOccEnv (text . show) occs
52+
, "getModuleExportsMap ="
53+
, printWithoutUniques $ mapUFM (text . show) mods
54+
, "}"
55+
]
56+
57+
-- | `updateExportsMap old new` results in an export map containing
58+
-- the union of old and new, but with all the module entries new overriding
59+
-- those in old.
60+
updateExportsMap :: ExportsMap -> ExportsMap -> ExportsMap
61+
updateExportsMap old new = ExportsMap
62+
{ getExportsMap = delListFromOccEnv (getExportsMap old) old_occs `plusOccEnv` getExportsMap new -- plusOccEnv is right biased
63+
, getModuleExportsMap = (getModuleExportsMap old) `plusUFM` (getModuleExportsMap new) -- plusUFM is right biased
64+
}
65+
where old_occs = concat [map name $ Set.toList (lookupWithDefaultUFM_Directly (getModuleExportsMap old) mempty m_uniq)
66+
| m_uniq <- nonDetKeysUFM (getModuleExportsMap new)]
5667

5768
size :: ExportsMap -> Int
58-
size = sum . map length . elems . getExportsMap
69+
size = sum . map (Set.size) . occEnvElts . getExportsMap
5970

60-
instance Semigroup ExportsMap where
61-
ExportsMap a b <> ExportsMap c d = ExportsMap (Map.unionWith (<>) a c) (Map.unionWith (<>) b d)
71+
mkVarOrDataOcc :: Text -> OccName
72+
mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t
73+
where
74+
mkOcc
75+
| Just (c,_) <- uncons t
76+
, c == ':' || isUpper c = mkDataOccFS
77+
| otherwise = mkVarOccFS
6278

63-
instance Monoid ExportsMap where
64-
mempty = ExportsMap Map.empty Map.empty
79+
mkTypeOcc :: Text -> OccName
80+
mkTypeOcc t = mkTcOccFS $ mkFastStringByteString $ encodeUtf8 t
6581

66-
type IdentifierText = Text
67-
type ModuleNameText = Text
82+
exportsMapSize :: ExportsMap -> Int
83+
exportsMapSize = foldOccEnv (\_ x -> x+1) 0 . getExportsMap
6884

85+
instance Semigroup ExportsMap where
86+
ExportsMap a b <> ExportsMap c d = ExportsMap (plusOccEnv_C (<>) a c) (plusUFM_C (<>) b d)
6987

70-
rendered :: IdentInfo -> IdentifierText
88+
instance Monoid ExportsMap where
89+
mempty = ExportsMap emptyOccEnv emptyUFM
90+
91+
rendered :: IdentInfo -> Text
7192
rendered = occNameText . name
7293

7394
-- | Render an identifier as imported or exported style.
7495
-- TODO: pattern synonymoccNameText :: OccName -> Text
75-
occNameText :: OccName -> IdentifierText
96+
occNameText :: OccName -> Text
7697
occNameText name
77-
| isTcOcc name && isSymOcc name = "type " <> renderOcc
78-
| otherwise = renderOcc
98+
| isTcOcc name && isSymOcc name = "type " <> renderedOcc
99+
| otherwise = renderedOcc
79100
where
80-
renderOcc = decodeUtf8 . bytesFS . occNameFS $ name
101+
renderedOcc = renderOcc name
102+
103+
renderOcc :: OccName -> Text
104+
renderOcc = decodeUtf8 . bytesFS . occNameFS
81105

82-
moduleNameText :: IdentInfo -> ModuleNameText
106+
moduleNameText :: IdentInfo -> Text
83107
moduleNameText = moduleNameText' . identModuleName
84108

85-
moduleNameText' :: ModuleName -> ModuleNameText
109+
moduleNameText' :: ModuleName -> Text
86110
moduleNameText' = decodeUtf8 . bytesFS . moduleNameFS
87111

88112
data IdentInfo = IdentInfo
@@ -129,39 +153,27 @@ mkIdentInfos mod (AvailTC _ nn flds)
129153
createExportsMap :: [ModIface] -> ExportsMap
130154
createExportsMap modIface = do
131155
let exportList = concatMap doOne modIface
132-
let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList
156+
let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList
133157
ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList
134158
where
135159
doOne modIFace = do
136160
let getModDetails = unpackAvail $ moduleName $ mi_module modIFace
137-
concatMap (fmap (second Set.fromList) . getModDetails) (mi_exports modIFace)
161+
concatMap (getModDetails) (mi_exports modIFace)
138162

139163
createExportsMapMg :: [ModGuts] -> ExportsMap
140164
createExportsMapMg modGuts = do
141165
let exportList = concatMap doOne modGuts
142-
let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList
166+
let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList
143167
ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList
144168
where
145169
doOne mi = do
146170
let getModuleName = moduleName $ mg_module mi
147-
concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi)
171+
concatMap (unpackAvail getModuleName) (mg_exports mi)
148172

149173
updateExportsMapMg :: [ModGuts] -> ExportsMap -> ExportsMap
150-
updateExportsMapMg modGuts old = old' <> new
174+
updateExportsMapMg modGuts old = updateExportsMap old new
151175
where
152176
new = createExportsMapMg modGuts
153-
old' = deleteAll old (Map.keys $ getModuleExportsMap new)
154-
deleteAll = foldl' (flip deleteEntriesForModule)
155-
156-
createExportsMapTc :: [TcGblEnv] -> ExportsMap
157-
createExportsMapTc modIface = do
158-
let exportList = concatMap doOne modIface
159-
let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList
160-
ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList
161-
where
162-
doOne mi = do
163-
let getModuleName = moduleName $ tcg_mod mi
164-
concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (tcg_exports mi)
165177

166178
nonInternalModules :: ModuleName -> Bool
167179
nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString
@@ -171,44 +183,44 @@ type WithHieDb = forall a. (HieDb -> IO a) -> IO a
171183
createExportsMapHieDb :: WithHieDb -> IO ExportsMap
172184
createExportsMapHieDb withHieDb = do
173185
mods <- withHieDb getAllIndexedMods
174-
idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do
186+
idents' <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do
175187
let mn = modInfoName $ hieModInfo m
176-
fmap (wrap . unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn)
177-
let exportsMap = Map.fromListWith (<>) (concat idents)
178-
return $! ExportsMap exportsMap $ buildModuleExportMap (concat idents)
188+
fmap (unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn)
189+
let idents = concat idents'
190+
let exportsMap = mkOccEnv_C (<>) (keyWith name idents)
191+
return $! ExportsMap exportsMap $ buildModuleExportMap (keyWith identModuleName idents)
179192
where
180-
wrap identInfo = (rendered identInfo, Set.fromList [identInfo])
181-
-- unwrap :: ExportRow -> IdentInfo
182193
unwrap m ExportRow{..} = IdentInfo exportName exportParent m
194+
keyWith f xs = [(f x, Set.singleton x) | x <- xs]
183195

184-
unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])]
196+
unpackAvail :: ModuleName -> IfaceExport -> [(OccName, ModuleName, HashSet IdentInfo)]
185197
unpackAvail mn
186198
| nonInternalModules mn = map f . mkIdentInfos mn
187199
| otherwise = const []
188200
where
189-
f id@IdentInfo {..} = (printOutputable name, moduleNameText id,[id])
201+
f id@IdentInfo {..} = (name, mn, Set.singleton id)
190202

191203

192-
identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo)
204+
identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo)
193205
identInfoToKeyVal identInfo =
194-
(moduleNameText identInfo, identInfo)
206+
(identModuleName identInfo, identInfo)
195207

196-
buildModuleExportMap:: [(Text, HashSet IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)
208+
buildModuleExportMap:: [(ModuleName, HashSet IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo)
197209
buildModuleExportMap exportsMap = do
198210
let lst = concatMap (Set.toList. snd) exportsMap
199211
let lstThree = map identInfoToKeyVal lst
200212
sortAndGroup lstThree
201213

202-
buildModuleExportMapFrom:: [ModIface] -> Map.HashMap Text (HashSet IdentInfo)
214+
buildModuleExportMapFrom:: [ModIface] -> ModuleNameEnv (HashSet IdentInfo)
203215
buildModuleExportMapFrom modIfaces = do
204216
let exports = map extractModuleExports modIfaces
205-
Map.fromListWith (<>) exports
217+
listToUFM_C (<>) exports
206218

207-
extractModuleExports :: ModIface -> (Text, HashSet IdentInfo)
219+
extractModuleExports :: ModIface -> (ModuleName, HashSet IdentInfo)
208220
extractModuleExports modIFace = do
209221
let modName = moduleName $ mi_module modIFace
210222
let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace
211-
(moduleNameText' modName, functionSet)
223+
(modName, functionSet)
212224

213-
sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)
214-
sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]
225+
sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo)
226+
sortAndGroup assocs = listToUFM_C (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]

0 commit comments

Comments
 (0)