-----------------------------------------------------------------------------
-- |
-- 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(..),
        emptyInstalledPackageInfo,
        parseInstalledPackageInfo,
        showInstalledPackageInfo,
        showFullInstalledPackageInfo,
        showInstalledPackageInfoField,
        showSimpleInstalledPackageInfoField,
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Data.Set                              (Set)
import Distribution.Backpack
import Distribution.CabalSpecVersion         (cabalSpecLatest)
import Distribution.FieldGrammar
import Distribution.FieldGrammar.FieldDescrs
import Distribution.ModuleName
import Distribution.Package                  hiding (installedPackageId, installedUnitId)
import Distribution.Types.ComponentName
import Distribution.Utils.Generic            (toUTF8BS)

import qualified Data.Map            as Map
import qualified Distribution.Fields as P
import qualified Text.PrettyPrint    as Disp

import Distribution.Types.InstalledPackageInfo
import Distribution.Types.InstalledPackageInfo.FieldGrammar



installedComponentId :: InstalledPackageInfo -> ComponentId
installedComponentId :: InstalledPackageInfo -> ComponentId
installedComponentId ipi :: InstalledPackageInfo
ipi =
    case ComponentId -> String
unComponentId (InstalledPackageInfo -> ComponentId
installedComponentId_ InstalledPackageInfo
ipi) of
        "" -> String -> ComponentId
mkComponentId (UnitId -> String
unUnitId (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
ipi))
        _  -> InstalledPackageInfo -> ComponentId
installedComponentId_ InstalledPackageInfo
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 :: InstalledPackageInfo -> OpenUnitId
installedOpenUnitId ipi :: InstalledPackageInfo
ipi
    = UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId
mkOpenUnitId (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
ipi) (InstalledPackageInfo -> ComponentId
installedComponentId InstalledPackageInfo
ipi) ([(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (InstalledPackageInfo -> [(ModuleName, OpenModule)]
instantiatedWith InstalledPackageInfo
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 :: InstalledPackageInfo -> Set ModuleName
requiredSignatures ipi :: InstalledPackageInfo
ipi = OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles ([(ModuleName, OpenModule)] -> OpenModuleSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (InstalledPackageInfo -> [(ModuleName, OpenModule)]
instantiatedWith InstalledPackageInfo
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 :: InstalledPackageInfo -> UnitId
installedPackageId = InstalledPackageInfo -> UnitId
installedUnitId

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

sourceComponentName :: InstalledPackageInfo -> ComponentName
sourceComponentName :: InstalledPackageInfo -> ComponentName
sourceComponentName = LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName)
-> (InstalledPackageInfo -> LibraryName)
-> InstalledPackageInfo
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> LibraryName
sourceLibName

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

-- | Return either errors, or IPI with list of warnings
--
-- /Note:/ errors array /may/ be empty, but the parse is still failed (it's a bug though)
parseInstalledPackageInfo
    :: String
    -> Either [String] ([String], InstalledPackageInfo)
parseInstalledPackageInfo :: String -> Either [String] ([String], InstalledPackageInfo)
parseInstalledPackageInfo s :: String
s = case ByteString -> Either ParseError [Field Position]
P.readFields (String -> ByteString
toUTF8BS String
s) of
    Left err :: ParseError
err -> [String] -> Either [String] ([String], InstalledPackageInfo)
forall a b. a -> Either a b
Left [ParseError -> String
forall a. Show a => a -> String
show ParseError
err]
    Right fs :: [Field Position]
fs -> case [Field Position] -> (Fields Position, [[Section Position]])
forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
fs of
        (fs' :: Fields Position
fs', _) -> case ParseResult InstalledPackageInfo
-> ([PWarning],
    Either (Maybe Version, [PError]) InstalledPackageInfo)
forall a.
ParseResult a -> ([PWarning], Either (Maybe Version, [PError]) a)
P.runParseResult (ParseResult InstalledPackageInfo
 -> ([PWarning],
     Either (Maybe Version, [PError]) InstalledPackageInfo))
-> ParseResult InstalledPackageInfo
-> ([PWarning],
    Either (Maybe Version, [PError]) InstalledPackageInfo)
forall a b. (a -> b) -> a -> b
$ CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo
-> ParseResult InstalledPackageInfo
forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
cabalSpecLatest Fields Position
fs' ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo
forall (g :: * -> * -> *).
(FieldGrammar g, Applicative (g InstalledPackageInfo),
 Applicative (g Basic)) =>
g InstalledPackageInfo InstalledPackageInfo
ipiFieldGrammar of
            (ws :: [PWarning]
ws, Right x :: InstalledPackageInfo
x) -> ([String], InstalledPackageInfo)
-> Either [String] ([String], InstalledPackageInfo)
forall a b. b -> Either a b
Right ([String]
ws', InstalledPackageInfo
x) where
                ws' :: [String]
ws' = (PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
P.showPWarning "") [PWarning]
ws
            (_,  Left (_, errs :: [PError]
errs)) -> [String] -> Either [String] ([String], InstalledPackageInfo)
forall a b. a -> Either a b
Left [String]
errs' where
                errs' :: [String]
errs' = (PError -> String) -> [PError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PError -> String
P.showPError "") [PError]
errs

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

-- | Pretty print 'InstalledPackageInfo'.
--
-- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4).
showInstalledPackageInfo :: InstalledPackageInfo -> String
showInstalledPackageInfo :: InstalledPackageInfo -> String
showInstalledPackageInfo ipi :: InstalledPackageInfo
ipi =
    InstalledPackageInfo -> String
showFullInstalledPackageInfo InstalledPackageInfo
ipi { pkgRoot :: Maybe String
pkgRoot = Maybe String
forall a. Maybe a
Nothing }

-- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.
showFullInstalledPackageInfo :: InstalledPackageInfo -> String
showFullInstalledPackageInfo :: InstalledPackageInfo -> String
showFullInstalledPackageInfo = [PrettyField] -> String
P.showFields ([PrettyField] -> String)
-> (InstalledPackageInfo -> [PrettyField])
-> InstalledPackageInfo
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo
-> InstalledPackageInfo -> [PrettyField]
forall s a. PrettyFieldGrammar s a -> s -> [PrettyField]
prettyFieldGrammar PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo
forall (g :: * -> * -> *).
(FieldGrammar g, Applicative (g InstalledPackageInfo),
 Applicative (g Basic)) =>
g InstalledPackageInfo InstalledPackageInfo
ipiFieldGrammar

-- |
--
-- >>> let ipi = emptyInstalledPackageInfo { maintainer = "Tester" }
-- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer"
-- Just "maintainer: Tester"
showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField fn :: String
fn =
    ((InstalledPackageInfo -> Doc) -> InstalledPackageInfo -> String)
-> Maybe (InstalledPackageInfo -> Doc)
-> Maybe (InstalledPackageInfo -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\g :: InstalledPackageInfo -> Doc
g -> Doc -> String
Disp.render (Doc -> String)
-> (InstalledPackageInfo -> Doc) -> InstalledPackageInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc -> Doc
ppField String
fn (Doc -> Doc)
-> (InstalledPackageInfo -> Doc) -> InstalledPackageInfo -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> Doc
g) (Maybe (InstalledPackageInfo -> Doc)
 -> Maybe (InstalledPackageInfo -> String))
-> Maybe (InstalledPackageInfo -> Doc)
-> Maybe (InstalledPackageInfo -> String)
forall a b. (a -> b) -> a -> b
$ FieldDescrs InstalledPackageInfo InstalledPackageInfo
-> ByteString -> Maybe (InstalledPackageInfo -> Doc)
forall s a. FieldDescrs s a -> ByteString -> Maybe (s -> Doc)
fieldDescrPretty FieldDescrs InstalledPackageInfo InstalledPackageInfo
forall (g :: * -> * -> *).
(FieldGrammar g, Applicative (g InstalledPackageInfo),
 Applicative (g Basic)) =>
g InstalledPackageInfo InstalledPackageInfo
ipiFieldGrammar (String -> ByteString
toUTF8BS String
fn)

showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showSimpleInstalledPackageInfoField fn :: String
fn =
    ((InstalledPackageInfo -> Doc) -> InstalledPackageInfo -> String)
-> Maybe (InstalledPackageInfo -> Doc)
-> Maybe (InstalledPackageInfo -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Style -> Doc -> String
Disp.renderStyle Style
myStyle (Doc -> String)
-> (InstalledPackageInfo -> Doc) -> InstalledPackageInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (Maybe (InstalledPackageInfo -> Doc)
 -> Maybe (InstalledPackageInfo -> String))
-> Maybe (InstalledPackageInfo -> Doc)
-> Maybe (InstalledPackageInfo -> String)
forall a b. (a -> b) -> a -> b
$ FieldDescrs InstalledPackageInfo InstalledPackageInfo
-> ByteString -> Maybe (InstalledPackageInfo -> Doc)
forall s a. FieldDescrs s a -> ByteString -> Maybe (s -> Doc)
fieldDescrPretty FieldDescrs InstalledPackageInfo InstalledPackageInfo
forall (g :: * -> * -> *).
(FieldGrammar g, Applicative (g InstalledPackageInfo),
 Applicative (g Basic)) =>
g InstalledPackageInfo InstalledPackageInfo
ipiFieldGrammar (String -> ByteString
toUTF8BS String
fn)
  where
    myStyle :: Style
myStyle = Style
Disp.style { mode :: Mode
Disp.mode = Mode
Disp.LeftMode }

ppField :: String -> Disp.Doc -> Disp.Doc
ppField :: String -> Doc -> Doc
ppField name :: String
name fielddoc :: Doc
fielddoc
     | Doc -> Bool
Disp.isEmpty Doc
fielddoc = Doc
forall a. Monoid a => a
mempty
     | Bool
otherwise             = String -> Doc
Disp.text String
name Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
Disp.<+> Doc
fielddoc