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