1{-# LANGUAGE DeriveAnyClass     #-}
2{-# LANGUAGE DerivingStrategies #-}
3module Development.IDE.Types.Exports
4(
5    IdentInfo(..),
6    ExportsMap(..),
7    createExportsMap,
8    createExportsMapMg,
9    createExportsMapTc,
10    buildModuleExportMapFrom
11,createExportsMapHieDb,size) where
12
13import           Avail                       (AvailInfo (..))
14import           Control.DeepSeq             (NFData (..))
15import           Control.Monad
16import           Data.Bifunctor              (Bifunctor (second))
17import           Data.HashMap.Strict         (HashMap, elems)
18import qualified Data.HashMap.Strict         as Map
19import           Data.HashSet                (HashSet)
20import qualified Data.HashSet                as Set
21import           Data.Hashable               (Hashable)
22import           Data.List                   (isSuffixOf)
23import           Data.Text                   (Text, pack)
24import           Development.IDE.GHC.Compat
25import           Development.IDE.GHC.Orphans ()
26import           Development.IDE.GHC.Util
27import           FieldLabel                  (flSelector)
28import           GHC.Generics                (Generic)
29import           GhcPlugins                  (IfaceExport, ModGuts (..))
30import           HieDb
31import           Name
32import           TcRnTypes                   (TcGblEnv (..))
33
34
35data ExportsMap = ExportsMap
36    {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)
37    , getModuleExportsMap :: Map.HashMap ModuleNameText (HashSet IdentInfo)
38    }
39    deriving (Show)
40
41size :: ExportsMap -> Int
42size = sum . map length . elems . getExportsMap
43
44instance Semigroup ExportsMap where
45  ExportsMap a b <> ExportsMap c d = ExportsMap (Map.unionWith (<>) a c) (Map.unionWith (<>) b d)
46
47instance Monoid ExportsMap where
48  mempty = ExportsMap Map.empty Map.empty
49
50type IdentifierText = Text
51type ModuleNameText = Text
52
53data IdentInfo = IdentInfo
54    { name           :: !OccName
55    , rendered       :: Text
56    , parent         :: !(Maybe Text)
57    , isDatacon      :: !Bool
58    , moduleNameText :: !Text
59    }
60    deriving (Generic, Show)
61    deriving anyclass Hashable
62
63instance Eq IdentInfo where
64    a == b = name a == name b
65          && parent a == parent b
66          && isDatacon a == isDatacon b
67          && moduleNameText a == moduleNameText b
68
69instance NFData IdentInfo where
70    rnf IdentInfo{..} =
71        -- deliberately skip the rendered field
72        rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText
73
74-- | Render an identifier as imported or exported style.
75-- TODO: pattern synonym
76renderIEWrapped :: Name -> Text
77renderIEWrapped n
78  | isTcOcc occ && isSymOcc occ = "type " <> pack (printName n)
79  | otherwise = pack $ printName n
80  where
81    occ = occName n
82
83mkIdentInfos :: Text -> AvailInfo -> [IdentInfo]
84mkIdentInfos mod (Avail n) =
85    [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]
86mkIdentInfos mod (AvailTC parent (n:nn) flds)
87    -- Following the GHC convention that parent == n if parent is exported
88    | n == parent
89    = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod
90        | n <- nn ++ map flSelector flds
91      ] ++
92      [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]
93    where
94        parentP = pack $ printName parent
95
96mkIdentInfos mod (AvailTC _ nn flds)
97    = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod
98        | n <- nn ++ map flSelector flds
99      ]
100
101createExportsMap :: [ModIface] -> ExportsMap
102createExportsMap modIface = do
103  let exportList = concatMap doOne modIface
104  let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList
105  ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList
106  where
107    doOne modIFace = do
108      let getModDetails = unpackAvail $ moduleName $ mi_module modIFace
109      concatMap (fmap (second Set.fromList) . getModDetails) (mi_exports modIFace)
110
111createExportsMapMg :: [ModGuts] -> ExportsMap
112createExportsMapMg modGuts = do
113  let exportList = concatMap doOne modGuts
114  let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList
115  ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList
116  where
117    doOne mi = do
118      let getModuleName = moduleName $ mg_module mi
119      concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi)
120
121createExportsMapTc :: [TcGblEnv] -> ExportsMap
122createExportsMapTc modIface = do
123  let exportList = concatMap doOne modIface
124  let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList
125  ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList
126  where
127    doOne mi = do
128      let getModuleName = moduleName $ tcg_mod mi
129      concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (tcg_exports mi)
130
131nonInternalModules :: ModuleName -> Bool
132nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString
133
134createExportsMapHieDb :: HieDb -> IO ExportsMap
135createExportsMapHieDb hiedb = do
136    mods <- getAllIndexedMods hiedb
137    idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do
138        let mn = modInfoName $ hieModInfo m
139            mText = pack $ moduleNameString mn
140        fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn
141    let exportsMap = Map.fromListWith (<>) (concat idents)
142    return $ ExportsMap exportsMap $ buildModuleExportMap (concat idents)
143  where
144    wrap identInfo = (rendered identInfo, Set.fromList [identInfo])
145    -- unwrap :: ExportRow -> IdentInfo
146    unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m
147      where
148          n = pack (occNameString exportName)
149          p = pack . occNameString <$> exportParent
150
151unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])]
152unpackAvail mn
153  | nonInternalModules mn = map f . mkIdentInfos mod
154  | otherwise = const []
155  where
156    !mod = pack $ moduleNameString mn
157    f id@IdentInfo {..} = (pack (prettyPrint name), moduleNameText,[id])
158
159
160identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo)
161identInfoToKeyVal identInfo =
162  (moduleNameText identInfo, identInfo)
163
164buildModuleExportMap:: [(Text, HashSet IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)
165buildModuleExportMap exportsMap = do
166  let lst = concatMap (Set.toList. snd) exportsMap
167  let lstThree = map identInfoToKeyVal lst
168  sortAndGroup lstThree
169
170buildModuleExportMapFrom:: [ModIface] -> Map.HashMap Text (HashSet IdentInfo)
171buildModuleExportMapFrom modIfaces = do
172  let exports = map extractModuleExports modIfaces
173  Map.fromListWith (<>) exports
174
175extractModuleExports :: ModIface -> (Text, HashSet IdentInfo)
176extractModuleExports modIFace = do
177  let modName = pack $ moduleNameString $ moduleName $ mi_module modIFace
178  let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace
179  (modName, functionSet)
180
181sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo)
182sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]
183