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

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.InstalledPackageInfo
-- Copyright   :  (c) The University of Glasgow 2004
--
-- Maintainer  :  [email protected]
-- 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)
  ]