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