Skip to content

Commit 2c01fb1

Browse files
wz1000wz1000
committed
export map improvements
1 parent 795dfa5 commit 2c01fb1

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
@@ -639,7 +639,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
639639
let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
640640
readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras)
641641
readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
642-
readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras)
642+
readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras)
643643
readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
644644
readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb
645645

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

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

182182
let moduleExports = getModuleExportsMap exportsMap
183-
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap
183+
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . occEnvElts . getExportsMap $ exportsMap
184184
exportsCompls = mempty{anyQualCompls = exportsCompItems}
185185
let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
186186

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

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -518,7 +518,7 @@ getCompletions
518518
-> PosPrefixInfo
519519
-> ClientCapabilities
520520
-> CompletionsConfig
521-
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
521+
-> ModuleNameEnv (HashSet.HashSet IdentInfo)
522522
-> Uri
523523
-> IO [Scored CompletionItem]
524524
getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
@@ -649,10 +649,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
649649
&& (List.length (words (T.unpack fullLine)) >= 2)
650650
&& "(" `isInfixOf` T.unpack fullLine
651651
-> do
652-
let moduleName = T.pack $ words (T.unpack fullLine) !! 1
653-
funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap
654-
funs = map (show . name) $ HashSet.toList funcs
655-
return $ filterModuleExports moduleName $ map T.pack funs
652+
let moduleName = words (T.unpack fullLine) !! 1
653+
funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName
654+
funs = map (renderOcc . name) $ HashSet.toList funcs
655+
return $ filterModuleExports (T.pack moduleName) funs
656656
| "import " `T.isPrefixOf` fullLine
657657
-> return filtImportCompls
658658
-- 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)