never executed always true always false
1 {-# LANGUAGE RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}
2
3 -- | Info about installed units (compiled libraries)
4 module GHC.Unit.Info
5 ( GenericUnitInfo (..)
6 , GenUnitInfo
7 , UnitInfo
8 , UnitKey (..)
9 , UnitKeyInfo
10 , mkUnitKeyInfo
11 , mapUnitInfo
12 , mkUnitPprInfo
13
14 , mkUnit
15
16 , PackageId(..)
17 , PackageName(..)
18 , Version(..)
19 , unitPackageNameString
20 , unitPackageIdString
21 , pprUnitInfo
22
23 , collectIncludeDirs
24 , collectExtraCcOpts
25 , collectLibraryDirs
26 , collectFrameworks
27 , collectFrameworksDirs
28 , unitHsLibs
29 )
30 where
31
32 import GHC.Prelude
33 import GHC.Platform.Ways
34
35 import GHC.Utils.Misc
36 import GHC.Utils.Outputable
37 import GHC.Utils.Panic
38
39 import GHC.Types.Unique
40
41 import GHC.Data.FastString
42 import qualified GHC.Data.ShortText as ST
43
44 import GHC.Unit.Module as Module
45 import GHC.Unit.Ppr
46 import GHC.Unit.Database
47
48 import GHC.Settings
49
50 import Data.Version
51 import Data.Bifunctor
52 import Data.List (isPrefixOf, stripPrefix)
53
54
55 -- | Information about an installed unit
56 --
57 -- We parameterize on the unit identifier:
58 -- * UnitKey: identifier used in the database (cf 'UnitKeyInfo')
59 -- * UnitId: identifier used to generate code (cf 'UnitInfo')
60 --
61 -- These two identifiers are different for wired-in packages. See Note [About
62 -- Units] in "GHC.Unit"
63 type GenUnitInfo unit = GenericUnitInfo PackageId PackageName unit ModuleName (GenModule (GenUnit unit))
64
65 -- | Information about an installed unit (units are identified by their database
66 -- UnitKey)
67 type UnitKeyInfo = GenUnitInfo UnitKey
68
69 -- | Information about an installed unit (units are identified by their internal
70 -- UnitId)
71 type UnitInfo = GenUnitInfo UnitId
72
73 -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo`
74 mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo
75 mkUnitKeyInfo = mapGenericUnitInfo
76 mkUnitKey'
77 mkPackageIdentifier'
78 mkPackageName'
79 mkModuleName'
80 mkModule'
81 where
82 mkPackageIdentifier' = PackageId . mkFastStringByteString
83 mkPackageName' = PackageName . mkFastStringByteString
84 mkUnitKey' = UnitKey . mkFastStringByteString
85 mkModuleName' = mkModuleNameFS . mkFastStringByteString
86 mkVirtUnitKey' i = case i of
87 DbInstUnitId cid insts -> mkVirtUnit (mkUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)
88 DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid))
89 mkModule' m = case m of
90 DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n)
91 DbModuleVar n -> mkHoleModule (mkModuleName' n)
92
93 -- | Map over the unit parameter
94 mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v
95 mapUnitInfo f = mapGenericUnitInfo
96 f -- unit identifier
97 id -- package identifier
98 id -- package name
99 id -- module name
100 (fmap (mapGenUnit f)) -- instantiating modules
101
102 newtype PackageId = PackageId FastString deriving (Eq)
103 newtype PackageName = PackageName
104 { unPackageName :: FastString
105 }
106 deriving (Eq)
107
108 instance Uniquable PackageId where
109 getUnique (PackageId n) = getUnique n
110
111 instance Uniquable PackageName where
112 getUnique (PackageName n) = getUnique n
113
114 instance Outputable PackageId where
115 ppr (PackageId str) = ftext str
116
117 instance Outputable PackageName where
118 ppr (PackageName str) = ftext str
119
120 unitPackageIdString :: GenUnitInfo u -> String
121 unitPackageIdString pkg = unpackFS str
122 where
123 PackageId str = unitPackageId pkg
124
125 unitPackageNameString :: GenUnitInfo u -> String
126 unitPackageNameString pkg = unpackFS str
127 where
128 PackageName str = unitPackageName pkg
129
130 pprUnitInfo :: UnitInfo -> SDoc
131 pprUnitInfo GenericUnitInfo {..} =
132 vcat [
133 field "name" (ppr unitPackageName),
134 field "version" (text (showVersion unitPackageVersion)),
135 field "id" (ppr unitId),
136 field "exposed" (ppr unitIsExposed),
137 field "exposed-modules" (ppr unitExposedModules),
138 field "hidden-modules" (fsep (map ppr unitHiddenModules)),
139 field "trusted" (ppr unitIsTrusted),
140 field "import-dirs" (fsep (map (text . ST.unpack) unitImportDirs)),
141 field "library-dirs" (fsep (map (text . ST.unpack) unitLibraryDirs)),
142 field "dynamic-library-dirs" (fsep (map (text . ST.unpack) unitLibraryDynDirs)),
143 field "hs-libraries" (fsep (map (text . ST.unpack) unitLibraries)),
144 field "extra-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsSys)),
145 field "extra-ghci-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsGhc)),
146 field "include-dirs" (fsep (map (text . ST.unpack) unitIncludeDirs)),
147 field "includes" (fsep (map (text . ST.unpack) unitIncludes)),
148 field "depends" (fsep (map ppr unitDepends)),
149 field "cc-options" (fsep (map (text . ST.unpack) unitCcOptions)),
150 field "ld-options" (fsep (map (text . ST.unpack) unitLinkerOptions)),
151 field "framework-dirs" (fsep (map (text . ST.unpack) unitExtDepFrameworkDirs)),
152 field "frameworks" (fsep (map (text . ST.unpack) unitExtDepFrameworks)),
153 field "haddock-interfaces" (fsep (map (text . ST.unpack) unitHaddockInterfaces)),
154 field "haddock-html" (fsep (map (text . ST.unpack) unitHaddockHTMLs))
155 ]
156 where
157 field name body = text name <> colon <+> nest 4 body
158
159 -- | Make a `Unit` from a `UnitInfo`
160 --
161 -- If the unit is definite, make a `RealUnit` from `unitId` field.
162 --
163 -- If the unit is indefinite, make a `VirtUnit` from `unitInstanceOf` and
164 -- `unitInstantiations` fields. Note that in this case we don't keep track of
165 -- `unitId`. It can be retrieved later with "improvement", i.e. matching on
166 -- `unitInstanceOf/unitInstantiations` fields (see Note [About units] in
167 -- GHC.Unit).
168 mkUnit :: UnitInfo -> Unit
169 mkUnit p
170 | unitIsIndefinite p = mkVirtUnit (unitInstanceOf p) (unitInstantiations p)
171 | otherwise = RealUnit (Definite (unitId p))
172
173 -- | Create a UnitPprInfo from a UnitInfo
174 mkUnitPprInfo :: (u -> FastString) -> GenUnitInfo u -> UnitPprInfo
175 mkUnitPprInfo ufs i = UnitPprInfo
176 (ufs (unitId i))
177 (unitPackageNameString i)
178 (unitPackageVersion i)
179 ((unpackFS . unPackageName) <$> unitComponentName i)
180
181 -- | Find all the include directories in the given units
182 collectIncludeDirs :: [UnitInfo] -> [FilePath]
183 collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps))
184
185 -- | Find all the C-compiler options in the given units
186 collectExtraCcOpts :: [UnitInfo] -> [String]
187 collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps)
188
189 -- | Find all the library directories in the given units for the given ways
190 collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath]
191 collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws)
192
193 -- | Find all the frameworks in the given units
194 collectFrameworks :: [UnitInfo] -> [String]
195 collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps)
196
197 -- | Find all the package framework paths in these and the preload packages
198 collectFrameworksDirs :: [UnitInfo] -> [String]
199 collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps)))
200
201 -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
202 libraryDirsForWay :: Ways -> UnitInfo -> [String]
203 libraryDirsForWay ws
204 | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs
205 | otherwise = map ST.unpack . unitLibraryDirs
206
207 unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String]
208 unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)
209 where
210 ways1 = removeWay WayDyn ways0
211 -- the name of a shared library is libHSfoo-ghc<version>.so
212 -- we leave out the _dyn, because it is superfluous
213
214 -- debug and profiled RTSs include support for -eventlog
215 ways2 | ways1 `hasWay` WayDebug || ways1 `hasWay` WayProf
216 = removeWay WayTracing ways1
217 | otherwise
218 = ways1
219
220 tag = waysTag (fullWays ways2)
221 rts_tag = waysTag ways2
222
223 mkDynName x
224 | not (ways0 `hasWay` WayDyn) = x
225 | "HS" `isPrefixOf` x = x ++ dynLibSuffix namever
226 -- For non-Haskell libraries, we use the name "Cfoo". The .a
227 -- file is libCfoo.a, and the .so is libfoo.so. That way the
228 -- linker knows what we mean for the vanilla (-lCfoo) and dyn
229 -- (-lfoo) ways. We therefore need to strip the 'C' off here.
230 | Just x' <- stripPrefix "C" x = x'
231 | otherwise
232 = panic ("Don't understand library name " ++ x)
233
234 -- Add _thr and other rts suffixes to packages named
235 -- `rts` or `rts-1.0`. Why both? Traditionally the rts
236 -- package is called `rts` only. However the tooling
237 -- usually expects a package name to have a version.
238 -- As such we will gradually move towards the `rts-1.0`
239 -- package name, at which point the `rts` package name
240 -- will eventually be unused.
241 --
242 -- This change elevates the need to add custom hooks
243 -- and handling specifically for the `rts` package for
244 -- example in ghc-cabal.
245 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
246 addSuffix rts@"HSrts-1.0.2" = rts ++ (expandTag rts_tag)
247 addSuffix other_lib = other_lib ++ (expandTag tag)
248
249 expandTag t | null t = ""
250 | otherwise = '_':t