Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

201 lines (163 sloc) 6.48 kb
{-# LANGUAGE CPP #-}
module PkgDB where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Distribution.Compiler
(CompilerId(..))
import Distribution.License
(License(..))
import Distribution.Version
(Version(..))
import Distribution.InstalledPackageInfo
(InstalledPackageInfo_(..), InstalledPackageInfo)
import Distribution.Package
(PackageName(..), PackageIdentifier(..), InstalledPackageId)
import Distribution.Simple.Compiler
(PackageDB(..),Compiler(..))
import Distribution.Simple.GHC
(configure, getInstalledPackages)
import Distribution.Simple.PackageIndex
(lookupPackageName, lookupSourcePackageId, lookupInstalledPackageId
, allPackages, fromList, reverseDependencyClosure
, topologicalOrder, PackageIndex)
import Distribution.Simple.Program.Db
(defaultProgramDb)
import Distribution.Verbosity
(normal)
import System.FilePath
import System.Directory
import Utils
type PkgDB = PackageIndex
type PkgInfo = InstalledPackageInfo
----------------------------------------------------------------
getPkgDB :: Maybe FilePath -> IO PkgDB
getPkgDB mpath = do
(com,pro) <- configure normal Nothing Nothing defaultProgramDb
let userDB = case mpath of
Nothing -> UserPackageDB
Just path -> SpecificPackageDB $ packageConf path com
getInstalledPackages normal [GlobalPackageDB,userDB] pro
getPackageConf :: FilePath -> IO FilePath
getPackageConf path = do
(com,_) <- configure normal Nothing Nothing defaultProgramDb
return $ packageConf path com
packageConf :: FilePath -> Compiler -> FilePath
packageConf path com = path </> "packages-" ++ version ver ++ ".conf"
where
CompilerId _ ver = compilerId com
toPkgDB :: [PkgInfo] -> PkgDB
toPkgDB = fromList
version :: Version -> String
version = toDotted . versionBranch
----------------------------------------------------------------
lookupByName :: String -> PkgDB -> [PkgInfo]
lookupByName name db = concatMap snd $ lookupPackageName db (PackageName name)
lookupByVersion :: String -> String -> PkgDB -> [PkgInfo]
lookupByVersion name ver db = lookupSourcePackageId db src
where
src = PackageIdentifier {
pkgName = PackageName name
, pkgVersion = Version {
versionBranch = fromDotted ver
, versionTags = []
}
}
----------------------------------------------------------------
toPkgList :: (PkgInfo -> Bool) -> PkgDB -> [PkgInfo]
toPkgList prd db = filter prd $ allPackages db
userPkgs :: IO (PkgInfo -> Bool)
userPkgs = do
#ifdef darwin_HOST_OS
-- drop "/."
userDirPref <- takeDirectory <$> getAppUserDataDirectory ""
#else
userDirPref <- getAppUserDataDirectory ""
#endif
return $ \pkgi -> case libraryDirs pkgi of
[] -> False -- haskell-platform for example
xs -> any (userDirPref `isPrefixOf`) xs
allPkgs :: IO (PkgInfo -> Bool)
allPkgs = return (const True)
----------------------------------------------------------------
fullNameOfPkgInfo :: PkgInfo -> String
fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ versionOfPkgInfo pkgi
pairNameOfPkgInfo :: PkgInfo -> (String,String)
pairNameOfPkgInfo pkgi = (nameOfPkgInfo pkgi, versionOfPkgInfo pkgi)
nameOfPkgInfo :: PkgInfo -> String
nameOfPkgInfo = toString . pkgName . sourcePackageId
where
toString (PackageName x) = x
versionOfPkgInfo :: PkgInfo -> String
versionOfPkgInfo = toDotted . numVersionOfPkgInfo
numVersionOfPkgInfo :: PkgInfo -> [Int]
numVersionOfPkgInfo = versionBranch . pkgVersion . sourcePackageId
----------------------------------------------------------------
extraInfo :: Bool -> PkgInfo -> IO ()
extraInfo False _ = return ()
extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ auth ++ "\""
where
lcns = showLicense (license pkgi)
auth = author pkgi
----------------------------------------------------------------
printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()
printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi
printDep :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageId -> IO ()
printDep rec info db n pid = case lookupInstalledPackageId db pid of
Nothing -> return ()
Just pkgi -> do
putStr $ prefix ++ fullNameOfPkgInfo pkgi
extraInfo info pkgi
putStrLn ""
when rec $ printDeps rec info db (n+1) pkgi
where
prefix = replicate (n * 4) ' '
showLicense :: License -> String
showLicense (GPL (Just v)) = "GPL" ++ version v
showLicense (GPL Nothing) = "GPL"
showLicense (LGPL (Just v)) = "LGPL" ++ version v
showLicense (LGPL Nothing) = "LGPL"
showLicense (UnknownLicense s) = s
showLicense x = show x
----------------------------------------------------------------
printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()
printRevDeps rec info db n pkgi = printRevDeps' rec info db revdb n pkgi
where
revdb = makeRevDepDB db
printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO ()
printRevDeps' rec info db revdb n pkgi = case M.lookup pkgid revdb of
Nothing -> return ()
Just pkgids -> mapM_ (printRevDep' rec info db revdb n) pkgids
where
pkgid = installedPackageId pkgi
printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO ()
printRevDep' rec info db revdb n pid = case lookupInstalledPackageId db pid of
Nothing -> return ()
Just pkgi -> do
putStr $ prefix ++ fullNameOfPkgInfo pkgi
extraInfo info pkgi
putStrLn ""
when rec $ printRevDeps' rec info db revdb (n+1) pkgi
where
prefix = replicate (n * 4) ' '
----------------------------------------------------------------
type RevDB = Map InstalledPackageId [InstalledPackageId]
makeRevDepDB :: PkgDB -> RevDB
makeRevDepDB db = M.fromList revdeps
where
pkgs = allPackages db
deps = map idDeps pkgs
idDeps pkg = (installedPackageId pkg, depends pkg)
kvs = sort $ concatMap decomp deps
decomp (k,vs) = map (\v -> (v,k)) vs
kvss = groupBy (\x y -> fst x == fst y) kvs
comp xs = (fst (head xs), map snd xs)
revdeps = map comp kvss
----------------------------------------------------------------
topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo]
topSortedPkgs pkgi db = topSort $ pkgids [pkgi]
where
pkgids = map installedPackageId
topSort = topologicalOrder . fromList . reverseDependencyClosure db
Jump to Line
Something went wrong with that request. Please try again.