module GHC.Unit.Info
( GenericUnitInfo (..)
, GenUnitInfo
, UnitInfo
, UnitKey (..)
, UnitKeyInfo
, mkUnitKeyInfo
, mapUnitInfo
, mkUnitPprInfo
, mkUnit
, PackageId(..)
, PackageName(..)
, Version(..)
, unitPackageNameString
, unitPackageIdString
, pprUnitInfo
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Unit.Database
import Data.Version
import Data.Bifunctor
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Unit.Module as Module
import GHC.Types.Unique
import GHC.Unit.Ppr
type GenUnitInfo unit = GenericUnitInfo (Indefinite unit) PackageId PackageName unit ModuleName (GenModule (GenUnit unit))
newtype UnitKey = UnitKey FastString
unitKeyFS :: UnitKey -> FastString
unitKeyFS (UnitKey fs) = fs
type UnitKeyInfo = GenUnitInfo UnitKey
type UnitInfo = GenUnitInfo UnitId
mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo
mkUnitKeyInfo = mapGenericUnitInfo
mkUnitKey'
mkIndefUnitKey'
mkPackageIdentifier'
mkPackageName'
mkModuleName'
mkModule'
where
mkPackageIdentifier' = PackageId . mkFastStringByteString
mkPackageName' = PackageName . mkFastStringByteString
mkUnitKey' = UnitKey . mkFastStringByteString
mkModuleName' = mkModuleNameFS . mkFastStringByteString
mkIndefUnitKey' cid = Indefinite (mkUnitKey' cid) Nothing
mkVirtUnitKey' i = case i of
DbInstUnitId cid insts -> mkGenVirtUnit unitKeyFS (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)
DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid))
mkModule' m = case m of
DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n)
DbModuleVar n -> mkHoleModule (mkModuleName' n)
mapUnitInfo :: (u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v
mapUnitInfo f gunitFS = mapGenericUnitInfo
f
(fmap f)
id
id
id
(fmap (mapGenUnit f gunitFS))
newtype PackageId = PackageId FastString deriving (Eq, Ord)
newtype PackageName = PackageName
{ unPackageName :: FastString
}
deriving (Eq, Ord)
instance Uniquable PackageId where
getUnique (PackageId n) = getUnique n
instance Uniquable PackageName where
getUnique (PackageName n) = getUnique n
instance Outputable PackageId where
ppr (PackageId str) = ftext str
instance Outputable PackageName where
ppr (PackageName str) = ftext str
unitPackageIdString :: GenUnitInfo u -> String
unitPackageIdString pkg = unpackFS str
where
PackageId str = unitPackageId pkg
unitPackageNameString :: GenUnitInfo u -> String
unitPackageNameString pkg = unpackFS str
where
PackageName str = unitPackageName pkg
pprUnitInfo :: UnitInfo -> SDoc
pprUnitInfo GenericUnitInfo {..} =
vcat [
field "name" (ppr unitPackageName),
field "version" (text (showVersion unitPackageVersion)),
field "id" (ppr unitId),
field "exposed" (ppr unitIsExposed),
field "exposed-modules" (ppr unitExposedModules),
field "hidden-modules" (fsep (map ppr unitHiddenModules)),
field "trusted" (ppr unitIsTrusted),
field "import-dirs" (fsep (map text unitImportDirs)),
field "library-dirs" (fsep (map text unitLibraryDirs)),
field "dynamic-library-dirs" (fsep (map text unitLibraryDynDirs)),
field "hs-libraries" (fsep (map text unitLibraries)),
field "extra-libraries" (fsep (map text unitExtDepLibsSys)),
field "extra-ghci-libraries" (fsep (map text unitExtDepLibsGhc)),
field "include-dirs" (fsep (map text unitIncludeDirs)),
field "includes" (fsep (map text unitIncludes)),
field "depends" (fsep (map ppr unitDepends)),
field "cc-options" (fsep (map text unitCcOptions)),
field "ld-options" (fsep (map text unitLinkerOptions)),
field "framework-dirs" (fsep (map text unitExtDepFrameworkDirs)),
field "frameworks" (fsep (map text unitExtDepFrameworks)),
field "haddock-interfaces" (fsep (map text unitHaddockInterfaces)),
field "haddock-html" (fsep (map text unitHaddockHTMLs))
]
where
field name body = text name <> colon <+> nest 4 body
mkUnit :: UnitInfo -> Unit
mkUnit p
| unitIsIndefinite p = mkVirtUnit (unitInstanceOf p) (unitInstantiations p)
| otherwise = RealUnit (Definite (unitId p))
mkUnitPprInfo :: GenUnitInfo u -> UnitPprInfo
mkUnitPprInfo i = UnitPprInfo
(unitPackageNameString i)
(unitPackageVersion i)
((unpackFS . unPackageName) <$> unitComponentName i)