{-# LANGUAGE CPP #-}
module Distribution.Cab.PkgDB (
  -- * Types
    PkgDB
  , PkgInfo
  -- * Obtaining 'PkgDB'
  , getPkgDB
  , getGlobalPkgDB
  , getUserPkgDB
  -- * Looking up
  , lookupByName
  , lookupByVersion
  -- * Topological sorting
  , topSortedPkgs
  -- * To 'PkgInfo'
  , toPkgInfos
  -- * From 'PkgInfo'
  , nameOfPkgInfo
  , fullNameOfPkgInfo
  , pairNameOfPkgInfo
  , verOfPkgInfo
  -- * Find other libraries
  , findInternalLibs
  , findSourceLib
  ) where

import Distribution.Cab.Utils
    (fromDotted, installedUnitId, mkPackageName, unPackageName)
import Distribution.Cab.Version
import Distribution.Cab.VerDB (PkgName)
import Distribution.InstalledPackageInfo
    (InstalledPackageInfo(depends), sourcePackageId, sourceLibName)
import Distribution.Package (PackageIdentifier(..))
#if MIN_VERSION_Cabal(3,14,0)
import Distribution.Simple.Compiler (PackageDB, PackageDBX(..))
#else
import Distribution.Simple.Compiler (PackageDB(..))
#endif
import Distribution.Simple.GHC (configure, getInstalledPackages, getPackageDBContents)
import Distribution.Simple.PackageIndex
    (lookupPackageName, lookupSourcePackageId, allPackages
    , fromList, reverseDependencyClosure, topologicalOrder)
#if MIN_VERSION_Cabal(1,22,0)
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
#else
import Distribution.Simple.PackageIndex (PackageIndex)
#endif
import Distribution.Simple.Program.Db (defaultProgramDb)
import Distribution.Types.LibraryName
import Distribution.Types.UnitId (unUnitId)
import Distribution.Types.UnqualComponentName (unUnqualComponentName)
import Distribution.Verbosity (normal)

#if MIN_VERSION_Cabal(3,14,0)
import Distribution.Utils.Path (makeSymbolicPath)
#endif

import Data.Char
import Data.Maybe

----------------------------------------------------------------

#if MIN_VERSION_Cabal(1,22,0)
type PkgDB = InstalledPackageIndex
#else
type PkgDB = PackageIndex
#endif
type PkgInfo = InstalledPackageInfo

----------------------------------------------------------------

-- | Obtaining 'PkgDB' for global and user
--
-- > getSandbox >>= getPkgDB
getPkgDB :: Maybe FilePath -> IO PkgDB
getPkgDB :: Maybe FilePath -> IO PkgDB
getPkgDB Maybe FilePath
mpath = [PackageDB] -> IO PkgDB
getDBs [PackageDB
GlobalPackageDB,PackageDB
userDB]
  where
    userDB :: PackageDB
userDB = Maybe FilePath -> PackageDB
toUserSpec Maybe FilePath
mpath

-- | Obtaining 'PkgDB' for user
getUserPkgDB :: Maybe FilePath -> IO PkgDB
getUserPkgDB :: Maybe FilePath -> IO PkgDB
getUserPkgDB Maybe FilePath
mpath = PackageDB -> IO PkgDB
getDB PackageDB
userDB
  where
    userDB :: PackageDB
userDB = Maybe FilePath -> PackageDB
toUserSpec Maybe FilePath
mpath

-- | Obtaining 'PkgDB' for global
getGlobalPkgDB :: IO PkgDB
getGlobalPkgDB :: IO PkgDB
getGlobalPkgDB = PackageDB -> IO PkgDB
getDB PackageDB
GlobalPackageDB

toUserSpec :: Maybe FilePath -> PackageDB
toUserSpec :: Maybe FilePath -> PackageDB
toUserSpec Maybe FilePath
Nothing     = PackageDB
UserPackageDB
#if MIN_VERSION_Cabal(3,14,0)
toUserSpec (Just path) = SpecificPackageDB $ makeSymbolicPath path
#else
toUserSpec (Just FilePath
path) = FilePath -> PackageDB
SpecificPackageDB FilePath
path
#endif

getDBs :: [PackageDB] -> IO PkgDB
getDBs :: [PackageDB] -> IO PkgDB
getDBs [PackageDB]
specs = do
    (Compiler
_comp,Maybe Platform
_,ProgramDb
pro) <- Verbosity
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
normal Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing ProgramDb
defaultProgramDb
    Verbosity -> Compiler -> [PackageDB] -> ProgramDb -> IO PkgDB
getInstalledPackages Verbosity
normal
#if MIN_VERSION_Cabal(1,23,0)
                         Compiler
_comp
#endif
#if MIN_VERSION_Cabal(3,14,0)
                         Nothing
#endif
                         [PackageDB]
specs ProgramDb
pro

getDB :: PackageDB -> IO PkgDB
getDB :: PackageDB -> IO PkgDB
getDB PackageDB
spec = do
    (Compiler
_,Maybe Platform
_,ProgramDb
pro) <- Verbosity
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
normal Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing ProgramDb
defaultProgramDb
    Verbosity -> PackageDB -> ProgramDb -> IO PkgDB
getPackageDBContents
      Verbosity
normal
#if MIN_VERSION_Cabal(3,14,0)
      Nothing
#endif
      PackageDB
spec ProgramDb
pro

----------------------------------------------------------------

-- |
--
-- > pkgdb <- getGlobalPkgDB
-- > lookupByName "base" pkgdb
lookupByName :: PkgName -> PkgDB -> [PkgInfo]
lookupByName :: FilePath -> PkgDB -> [PkgInfo]
lookupByName FilePath
name PkgDB
db = ((Version, [PkgInfo]) -> [PkgInfo])
-> [(Version, [PkgInfo])] -> [PkgInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Version, [PkgInfo]) -> [PkgInfo]
forall a b. (a, b) -> b
snd ([(Version, [PkgInfo])] -> [PkgInfo])
-> [(Version, [PkgInfo])] -> [PkgInfo]
forall a b. (a -> b) -> a -> b
$ PkgDB -> PackageName -> [(Version, [PkgInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
lookupPackageName PkgDB
db (FilePath -> PackageName
mkPackageName FilePath
name)

-- |
--
-- > pkgdb <- getGlobalPkgDB
-- > lookupByVersion "base" "4.6.0.1" pkgdb
lookupByVersion :: PkgName -> String -> PkgDB -> [PkgInfo]
lookupByVersion :: FilePath -> FilePath -> PkgDB -> [PkgInfo]
lookupByVersion FilePath
name FilePath
ver PkgDB
db = PkgDB -> PackageId -> [PkgInfo]
forall a. PackageIndex a -> PackageId -> [a]
lookupSourcePackageId PkgDB
db PackageId
src
  where
    src :: PackageId
src = PackageIdentifier {
        pkgName :: PackageName
pkgName = FilePath -> PackageName
mkPackageName FilePath
name
      , pkgVersion :: Version
pkgVersion = [Int] -> Version
toVersion ([Int] -> Version) -> [Int] -> Version
forall a b. (a -> b) -> a -> b
$ FilePath -> [Int]
fromDotted FilePath
ver
      }

----------------------------------------------------------------

toPkgInfos :: PkgDB -> [PkgInfo]
toPkgInfos :: PkgDB -> [PkgInfo]
toPkgInfos PkgDB
db = PkgDB -> [PkgInfo]
forall a. PackageIndex a -> [a]
allPackages PkgDB
db

----------------------------------------------------------------

nameOfPkgInfo :: PkgInfo -> PkgName
nameOfPkgInfo :: PkgInfo -> FilePath
nameOfPkgInfo PkgInfo
pkgi = case PkgInfo -> LibraryName
sourceLibName PkgInfo
pkgi of
    LibraryName
LMainLibName -> FilePath
name
    LSubLibName UnqualComponentName
sub -> FilePath -> FilePath -> FilePath
libNameHack FilePath
name (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
sub
  where
   name :: FilePath
name =  PackageName -> FilePath
unPackageName (PackageName -> FilePath) -> PackageName -> FilePath
forall a b. (a -> b) -> a -> b
$ PackageId -> PackageName
pkgName (PackageId -> PackageName) -> PackageId -> PackageName
forall a b. (a -> b) -> a -> b
$ PkgInfo -> PackageId
sourcePackageId PkgInfo
pkgi

fullNameOfPkgInfo :: PkgInfo -> String
fullNameOfPkgInfo :: PkgInfo -> FilePath
fullNameOfPkgInfo PkgInfo
pkgi = PkgInfo -> FilePath
nameOfPkgInfo PkgInfo
pkgi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Ver -> FilePath
verToString (PkgInfo -> Ver
verOfPkgInfo PkgInfo
pkgi)

pairNameOfPkgInfo :: PkgInfo -> (PkgName,String)
pairNameOfPkgInfo :: PkgInfo -> (FilePath, FilePath)
pairNameOfPkgInfo PkgInfo
pkgi = (PkgInfo -> FilePath
nameOfPkgInfo PkgInfo
pkgi, Ver -> FilePath
verToString (PkgInfo -> Ver
verOfPkgInfo PkgInfo
pkgi))

verOfPkgInfo :: PkgInfo -> Ver
verOfPkgInfo :: PkgInfo -> Ver
verOfPkgInfo = Version -> Ver
version (Version -> Ver) -> (PkgInfo -> Version) -> PkgInfo -> Ver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> Version
pkgVersion (PackageId -> Version)
-> (PkgInfo -> PackageId) -> PkgInfo -> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgInfo -> PackageId
sourcePackageId

----------------------------------------------------------------

topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo]
topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo]
topSortedPkgs PkgInfo
pkgi PkgDB
db = [UnitId] -> [PkgInfo]
topSort ([UnitId] -> [PkgInfo]) -> [UnitId] -> [PkgInfo]
forall a b. (a -> b) -> a -> b
$ [PkgInfo] -> [UnitId]
unitids [PkgInfo
pkgi]
  where
    unitids :: [PkgInfo] -> [UnitId]
unitids = (PkgInfo -> UnitId) -> [PkgInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map PkgInfo -> UnitId
installedUnitId
    topSort :: [UnitId] -> [PkgInfo]
topSort = PkgDB -> [PkgInfo]
forall a. PackageInstalled a => PackageIndex a -> [a]
topologicalOrder (PkgDB -> [PkgInfo])
-> ([UnitId] -> PkgDB) -> [UnitId] -> [PkgInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PkgInfo] -> PkgDB
fromList ([PkgInfo] -> PkgDB)
-> ([UnitId] -> [PkgInfo]) -> [UnitId] -> PkgDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgDB -> [UnitId] -> [PkgInfo]
forall a. PackageInstalled a => PackageIndex a -> [UnitId] -> [a]
reverseDependencyClosure PkgDB
db

----------------------------------------------------------------

findInternalLibs :: PkgInfo -> String -> [String]
findInternalLibs :: PkgInfo -> FilePath -> [FilePath]
findInternalLibs PkgInfo
pkgInfo FilePath
name = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
libNameHack FilePath
name) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath]) -> [Maybe FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Maybe FilePath) -> [UnitId] -> [Maybe FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe FilePath
getInternalLib (FilePath -> Maybe FilePath)
-> (UnitId -> FilePath) -> UnitId -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> FilePath
unUnitId) ([UnitId] -> [Maybe FilePath]) -> [UnitId] -> [Maybe FilePath]
forall a b. (a -> b) -> a -> b
$ PkgInfo -> [UnitId]
depends PkgInfo
pkgInfo

getInternalLib :: String -> Maybe String
getInternalLib :: FilePath -> Maybe FilePath
getInternalLib FilePath
xs0 = case Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
22 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
skip FilePath
xs0 of
  Char
_:FilePath
xs1   -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
xs1
  FilePath
_       -> Maybe FilePath
forall a. Maybe a
Nothing
  where
    skip :: FilePath -> FilePath
skip FilePath
ys = case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') FilePath
ys of
      (FilePath
_,Char
'-':Char
b:FilePath
bs)
        | Char -> Bool
isDigit Char
b -> case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') FilePath
bs of
            (FilePath
_,Char
'-':FilePath
ds) -> FilePath
ds
            (FilePath, FilePath)
_          -> FilePath
"" -- error
        | Bool
otherwise -> FilePath -> FilePath
skip FilePath
bs
      (FilePath, FilePath)
_  -> FilePath
"" -- error


----------------------------------------------------------------

-- A cabal package can exports multiple libraries.
findSourceLib :: PkgDB -> PkgInfo -> [PkgInfo]
findSourceLib :: PkgDB -> PkgInfo -> [PkgInfo]
findSourceLib PkgDB
db PkgInfo
pkgi = case PkgInfo -> LibraryName
sourceLibName PkgInfo
pkgi of
  -- Only one library is exported.
  LibraryName
LMainLibName -> []
  -- This is a sub library. Need to find a main(source) library.
  LSubLibName UnqualComponentName
_ -> PkgDB -> PackageId -> [PkgInfo]
forall a. PackageIndex a -> PackageId -> [a]
lookupSourcePackageId PkgDB
db (PackageId -> [PkgInfo]) -> PackageId -> [PkgInfo]
forall a b. (a -> b) -> a -> b
$ PkgInfo -> PackageId
sourcePackageId PkgInfo
pkgi

----------------------------------------------------------------

libNameHack :: String -> String -> String
libNameHack :: FilePath -> FilePath -> FilePath
libNameHack FilePath
name FilePath
subname = FilePath
"z-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-z-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
subname