Distribution/InstalledPackageInfo.hs

    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE TypeFamilies #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.InstalledPackageInfo
    -- Copyright   :  (c) The University of Glasgow 2004
    --
    -- Maintainer  :  libraries@haskell.org
    -- Portability :  portable
    --
    -- This is the information about an /installed/ package that
    -- is communicated to the @ghc-pkg@ program in order to register
    -- a package.  @ghc-pkg@ now consumes this package format (as of version
    -- 6.4). This is specific to GHC at the moment.
    --
    -- The @.cabal@ file format is for describing a package that is not yet
    -- installed. It has a lot of flexibility, like conditionals and dependency
    -- ranges. As such, that format is not at all suitable for describing a package
    -- that has already been built and installed. By the time we get to that stage,
    -- we have resolved all conditionals and resolved dependency version
    -- constraints to exact versions of dependent packages. So, this module defines
    -- the 'InstalledPackageInfo' data structure that contains all the info we keep
    -- about an installed package. There is a parser and pretty printer. The
    -- textual format is rather simpler than the @.cabal@ format: there are no
    -- sections, for example.

    -- This module is meant to be local-only to Distribution...

    module Distribution.InstalledPackageInfo (
            InstalledPackageInfo(..),
            installedPackageId,
            installedComponentId,
            installedOpenUnitId,
            sourceComponentName,
            requiredSignatures,
            ExposedModule(..),
            AbiDependency(..),
            ParseResult(..), PError(..), PWarning,
            emptyInstalledPackageInfo,
            parseInstalledPackageInfo,
            showInstalledPackageInfo,
            showInstalledPackageInfoField,
            showSimpleInstalledPackageInfoField,
            fieldsInstalledPackageInfo,
      ) where

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.ParseUtils
    import Distribution.License
    import Distribution.Package hiding (installedUnitId, installedPackageId)
    import Distribution.Backpack
    import qualified Distribution.Package as Package
    import Distribution.ModuleName
    import Distribution.Version
    import Distribution.Text
    import qualified Distribution.Compat.ReadP as Parse
    import Distribution.Compat.Graph
    import Distribution.Types.MungedPackageId
    import Distribution.Types.ComponentName
    import Distribution.Types.MungedPackageName
    import Distribution.Types.UnqualComponentName

    import Text.PrettyPrint as Disp
    import qualified Data.Char as Char
    import qualified Data.Map as Map
    import Data.Set (Set)

    -- -----------------------------------------------------------------------------
    -- The InstalledPackageInfo type

    -- For BC reasons, we continue to name this record an InstalledPackageInfo;
    -- but it would more accurately be called an InstalledUnitInfo with Backpack
    data InstalledPackageInfo
       = InstalledPackageInfo {
            -- these parts are exactly the same as PackageDescription
            sourcePackageId   :: PackageId,
            installedUnitId   :: UnitId,
            installedComponentId_ :: ComponentId,
            -- INVARIANT: if this package is definite, OpenModule's
            -- OpenUnitId directly records UnitId.  If it is
            -- indefinite, OpenModule is always an OpenModuleVar
            -- with the same ModuleName as the key.
            instantiatedWith  :: [(ModuleName, OpenModule)],
            sourceLibName     :: Maybe UnqualComponentName,
            compatPackageKey  :: String,
            license           :: License,
            copyright         :: String,
            maintainer        :: String,
            author            :: String,
            stability         :: String,
            homepage          :: String,
            pkgUrl            :: String,
            synopsis          :: String,
            description       :: String,
            category          :: String,
            -- these parts are required by an installed package only:
            abiHash           :: AbiHash,
            indefinite        :: Bool,
            exposed           :: Bool,
            -- INVARIANT: if the package is definite, OpenModule's
            -- OpenUnitId directly records UnitId.
            exposedModules    :: [ExposedModule],
            hiddenModules     :: [ModuleName],
            trusted           :: Bool,
            importDirs        :: [FilePath],
            libraryDirs       :: [FilePath],
            libraryDynDirs    :: [FilePath],  -- ^ overrides 'libraryDirs'
            dataDir           :: FilePath,
            hsLibraries       :: [String],
            extraLibraries    :: [String],
            extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi
            includeDirs       :: [FilePath],
            includes          :: [String],
            -- INVARIANT: if the package is definite, UnitId is NOT
            -- a ComponentId of an indefinite package
            depends           :: [UnitId],
            abiDepends        :: [AbiDependency],
            ccOptions         :: [String],
            ldOptions         :: [String],
            frameworkDirs     :: [FilePath],
            frameworks        :: [String],
            haddockInterfaces :: [FilePath],
            haddockHTMLs      :: [FilePath],
            pkgRoot           :: Maybe FilePath
        }
        deriving (Eq, Generic, Typeable, Read, Show)

    installedComponentId :: InstalledPackageInfo -> ComponentId
    installedComponentId ipi =
        case unComponentId (installedComponentId_ ipi) of
            "" -> mkComponentId (unUnitId (installedUnitId ipi))
            _  -> installedComponentId_ ipi

    -- | Get the indefinite unit identity representing this package.
    -- This IS NOT guaranteed to give you a substitution; for
    -- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@.
    -- For indefinite libraries, however, you will correctly get
    -- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'.
    installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId
    installedOpenUnitId ipi
        = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi))

    -- | Returns the set of module names which need to be filled for
    -- an indefinite package, or the empty set if the package is definite.
    requiredSignatures :: InstalledPackageInfo -> Set ModuleName
    requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi))

    {-# DEPRECATED installedPackageId "Use installedUnitId instead" #-}
    -- | Backwards compatibility with Cabal pre-1.24.
    --
    -- This type synonym is slightly awful because in cabal-install
    -- we define an 'InstalledPackageId' but it's a ComponentId,
    -- not a UnitId!
    installedPackageId :: InstalledPackageInfo -> UnitId
    installedPackageId = installedUnitId

    instance Binary InstalledPackageInfo

    instance Package.HasMungedPackageId InstalledPackageInfo where
       mungedId = mungedPackageId

    instance Package.Package InstalledPackageInfo where
       packageId = sourcePackageId

    instance Package.HasUnitId InstalledPackageInfo where
       installedUnitId = installedUnitId

    instance Package.PackageInstalled InstalledPackageInfo where
       installedDepends = depends

    instance IsNode InstalledPackageInfo where
        type Key InstalledPackageInfo = UnitId
        nodeKey       = installedUnitId
        nodeNeighbors = depends

    emptyInstalledPackageInfo :: InstalledPackageInfo
    emptyInstalledPackageInfo
       = InstalledPackageInfo {
            sourcePackageId   = PackageIdentifier (mkPackageName "") nullVersion,
            installedUnitId   = mkUnitId "",
            installedComponentId_ = mkComponentId "",
            instantiatedWith  = [],
            sourceLibName     = Nothing,
            compatPackageKey  = "",
            license           = UnspecifiedLicense,
            copyright         = "",
            maintainer        = "",
            author            = "",
            stability         = "",
            homepage          = "",
            pkgUrl            = "",
            synopsis          = "",
            description       = "",
            category          = "",
            abiHash           = mkAbiHash "",
            indefinite        = False,
            exposed           = False,
            exposedModules    = [],
            hiddenModules     = [],
            trusted           = False,
            importDirs        = [],
            libraryDirs       = [],
            libraryDynDirs    = [],
            dataDir           = "",
            hsLibraries       = [],
            extraLibraries    = [],
            extraGHCiLibraries= [],
            includeDirs       = [],
            includes          = [],
            depends           = [],
            abiDepends        = [],
            ccOptions         = [],
            ldOptions         = [],
            frameworkDirs     = [],
            frameworks        = [],
            haddockInterfaces = [],
            haddockHTMLs      = [],
            pkgRoot           = Nothing
        }

    -- -----------------------------------------------------------------------------
    -- Exposed modules

    data ExposedModule
       = ExposedModule {
           exposedName      :: ModuleName,
           exposedReexport  :: Maybe OpenModule
         }
      deriving (Eq, Generic, Read, Show)

    instance Text ExposedModule where
        disp (ExposedModule m reexport) =
            Disp.hsep [ disp m
                      , case reexport of
                         Just m' -> Disp.hsep [Disp.text "from", disp m']
                         Nothing -> Disp.empty
                      ]
        parse = do
            m <- parseModuleNameQ
            Parse.skipSpaces
            reexport <- Parse.option Nothing $ do
                _ <- Parse.string "from"
                Parse.skipSpaces
                fmap Just parse
            return (ExposedModule m reexport)

    instance Binary ExposedModule

    -- To maintain backwards-compatibility, we accept both comma/non-comma
    -- separated variants of this field.  You SHOULD use the comma syntax if you
    -- use any new functions, although actually it's unambiguous due to a quirk
    -- of the fact that modules must start with capital letters.

    showExposedModules :: [ExposedModule] -> Disp.Doc
    showExposedModules xs
        | all isExposedModule xs = fsep (map disp xs)
        | otherwise = fsep (Disp.punctuate comma (map disp xs))
        where isExposedModule (ExposedModule _ Nothing) = True
              isExposedModule _ = False

    parseExposedModules :: Parse.ReadP r [ExposedModule]
    parseExposedModules = parseOptCommaList parse

    dispMaybe :: Text a => Maybe a -> Disp.Doc
    dispMaybe Nothing = Disp.empty
    dispMaybe (Just x) = disp x

    parseMaybe :: Text a => Parse.ReadP r (Maybe a)
    parseMaybe = fmap Just parse Parse.<++ return Nothing

    -- -----------------------------------------------------------------------------
    -- ABI dependency

    -- | An ABI dependency is a dependency on a library which also
    -- records the ABI hash ('abiHash') of the library it depends
    -- on.
    --
    -- The primary utility of this is to enable an extra sanity when
    -- GHC loads libraries: it can check if the dependency has a matching
    -- ABI and if not, refuse to load this library.  This information
    -- is critical if we are shadowing libraries; differences in the
    -- ABI hash let us know what packages get shadowed by the new version
    -- of a package.
    data AbiDependency = AbiDependency {
            depUnitId  :: UnitId,
            depAbiHash :: AbiHash
        }
      deriving (Eq, Generic, Read, Show)

    instance Text AbiDependency where
        disp (AbiDependency uid abi) =
            disp uid <<>> Disp.char '=' <<>> disp abi
        parse = do
            uid <- parse
            _ <- Parse.char '='
            abi <- parse
            return (AbiDependency uid abi)

    instance Binary AbiDependency

    -- -----------------------------------------------------------------------------
    -- Munging

    sourceComponentName :: InstalledPackageInfo -> ComponentName
    sourceComponentName ipi =
        case sourceLibName ipi of
            Nothing -> CLibName
            Just qn -> CSubLibName qn

    -- | Returns @Just@ if the @name@ field of the IPI record would not contain
    -- the package name verbatim.  This helps us avoid writing @package-name@
    -- when it's redundant.
    maybePackageName :: InstalledPackageInfo -> Maybe PackageName
    maybePackageName ipi =
        case sourceLibName ipi of
            Nothing -> Nothing
            Just _ -> Just (packageName ipi)

    -- | Setter for the @package-name@ field.  It should be acceptable for this
    -- to be a no-op.
    setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo
    setMaybePackageName Nothing ipi = ipi
    setMaybePackageName (Just pn) ipi = ipi {
            sourcePackageId=(sourcePackageId ipi){pkgName=pn}
        }

    -- | Returns the munged package name, which we write into @name@ for
    -- compatibility with old versions of GHC.
    mungedPackageName :: InstalledPackageInfo -> MungedPackageName
    mungedPackageName ipi =
        computeCompatPackageName
            (packageName ipi)
            (sourceLibName ipi)

    setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo
    setMungedPackageName mpn ipi =
        let (pn, mb_uqn) = decodeCompatPackageName mpn
        in ipi {
                sourcePackageId = (sourcePackageId ipi) {pkgName=pn},
                sourceLibName   = mb_uqn
            }

    mungedPackageId :: InstalledPackageInfo -> MungedPackageId
    mungedPackageId ipi =
        MungedPackageId (mungedPackageName ipi) (packageVersion ipi)

    -- -----------------------------------------------------------------------------
    -- Parsing

    parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
    parseInstalledPackageInfo =
        parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs)
        emptyInstalledPackageInfo

    -- -----------------------------------------------------------------------------
    -- Pretty-printing

    showInstalledPackageInfo :: InstalledPackageInfo -> String
    showInstalledPackageInfo = showFields fieldsInstalledPackageInfo

    showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
    showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo

    showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
    showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo

    dispCompatPackageKey :: String -> Doc
    dispCompatPackageKey = text

    parseCompatPackageKey :: Parse.ReadP r String
    parseCompatPackageKey = Parse.munch1 uid_char
        where uid_char c = Char.isAlphaNum c || c `elem` "-_.=[],:<>+"

    -- -----------------------------------------------------------------------------
    -- Description of the fields, for parsing/printing

    fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo]
    fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs

    basicFieldDescrs :: [FieldDescr InstalledPackageInfo]
    basicFieldDescrs =
     [ simpleField "name"
                               disp                   (parseMaybeQuoted parse)
                               mungedPackageName      setMungedPackageName
     , simpleField "version"
                               disp                   parseOptVersion
                               packageVersion         (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})
     , simpleField "id"
                               disp                   parse
                               installedUnitId        (\pk pkg -> pkg{installedUnitId=pk})
     , simpleField "instantiated-with"
            (dispOpenModuleSubst . Map.fromList)    (fmap Map.toList parseOpenModuleSubst)
            instantiatedWith   (\iw    pkg -> pkg{instantiatedWith=iw})
     , simpleField "package-name"
                               dispMaybe              parseMaybe
                               maybePackageName       setMaybePackageName
     , simpleField "lib-name"
                               dispMaybe              parseMaybe
                               sourceLibName          (\n pkg -> pkg{sourceLibName=n})
     , simpleField "key"
                               dispCompatPackageKey   parseCompatPackageKey
                               compatPackageKey       (\pk pkg -> pkg{compatPackageKey=pk})
     , simpleField "license"
                               disp                   parseLicenseQ
                               license                (\l pkg -> pkg{license=l})
     , simpleField "copyright"
                               showFreeText           parseFreeText
                               copyright              (\val pkg -> pkg{copyright=val})
     , simpleField "maintainer"
                               showFreeText           parseFreeText
                               maintainer             (\val pkg -> pkg{maintainer=val})
     , simpleField "stability"
                               showFreeText           parseFreeText
                               stability              (\val pkg -> pkg{stability=val})
     , simpleField "homepage"
                               showFreeText           parseFreeText
                               homepage               (\val pkg -> pkg{homepage=val})
     , simpleField "package-url"
                               showFreeText           parseFreeText
                               pkgUrl                 (\val pkg -> pkg{pkgUrl=val})
     , simpleField "synopsis"
                               showFreeText           parseFreeText
                               synopsis               (\val pkg -> pkg{synopsis=val})
     , simpleField "description"
                               showFreeText           parseFreeText
                               description            (\val pkg -> pkg{description=val})
     , simpleField "category"
                               showFreeText           parseFreeText
                               category               (\val pkg -> pkg{category=val})
     , simpleField "author"
                               showFreeText           parseFreeText
                               author                 (\val pkg -> pkg{author=val})
     ]

    installedFieldDescrs :: [FieldDescr InstalledPackageInfo]
    installedFieldDescrs = [
       boolField "exposed"
            exposed            (\val pkg -> pkg{exposed=val})
     , boolField "indefinite"
            indefinite         (\val pkg -> pkg{indefinite=val})
     , simpleField "exposed-modules"
            showExposedModules parseExposedModules
            exposedModules     (\xs    pkg -> pkg{exposedModules=xs})
     , listField   "hidden-modules"
            disp               parseModuleNameQ
            hiddenModules      (\xs    pkg -> pkg{hiddenModules=xs})
     , simpleField "abi"
            disp               parse
            abiHash            (\abi    pkg -> pkg{abiHash=abi})
     , boolField   "trusted"
            trusted            (\val pkg -> pkg{trusted=val})
     , listField   "import-dirs"
            showFilePath       parseFilePathQ
            importDirs         (\xs pkg -> pkg{importDirs=xs})
     , listField   "library-dirs"
            showFilePath       parseFilePathQ
            libraryDirs        (\xs pkg -> pkg{libraryDirs=xs})
     , listField   "dynamic-library-dirs"
            showFilePath       parseFilePathQ
            libraryDynDirs     (\xs pkg -> pkg{libraryDynDirs=xs})
     , simpleField "data-dir"
            showFilePath       (parseFilePathQ Parse.<++ return "")
            dataDir            (\val pkg -> pkg{dataDir=val})
     , listField   "hs-libraries"
            showFilePath       parseTokenQ
            hsLibraries        (\xs pkg -> pkg{hsLibraries=xs})
     , listField   "extra-libraries"
            showToken          parseTokenQ
            extraLibraries     (\xs pkg -> pkg{extraLibraries=xs})
     , listField   "extra-ghci-libraries"
            showToken          parseTokenQ
            extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs})
     , listField   "include-dirs"
            showFilePath       parseFilePathQ
            includeDirs        (\xs pkg -> pkg{includeDirs=xs})
     , listField   "includes"
            showFilePath       parseFilePathQ
            includes           (\xs pkg -> pkg{includes=xs})
     , listField   "depends"
            disp               parse
            depends            (\xs pkg -> pkg{depends=xs})
     , listField   "abi-depends"
            disp               parse
            abiDepends         (\xs pkg -> pkg{abiDepends=xs})
     , listField   "cc-options"
            showToken          parseTokenQ
            ccOptions          (\path  pkg -> pkg{ccOptions=path})
     , listField   "ld-options"
            showToken          parseTokenQ
            ldOptions          (\path  pkg -> pkg{ldOptions=path})
     , listField   "framework-dirs"
            showFilePath       parseFilePathQ
            frameworkDirs      (\xs pkg -> pkg{frameworkDirs=xs})
     , listField   "frameworks"
            showToken          parseTokenQ
            frameworks         (\xs pkg -> pkg{frameworks=xs})
     , listField   "haddock-interfaces"
            showFilePath       parseFilePathQ
            haddockInterfaces  (\xs pkg -> pkg{haddockInterfaces=xs})
     , listField   "haddock-html"
            showFilePath       parseFilePathQ
            haddockHTMLs       (\xs pkg -> pkg{haddockHTMLs=xs})
     , simpleField "pkgroot"
            (const Disp.empty)        parseFilePathQ
            (fromMaybe "" . pkgRoot)  (\xs pkg -> pkg{pkgRoot=Just xs})
     ]

    deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo]
    deprecatedFieldDescrs = [
       listField   "hugs-options"
            showToken          parseTokenQ
            (const [])        (const id)
      ]