Dependency.hs 8.78 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.Hackage.CabalInstall.Dependency
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Various kinds of dependency resolution and utilities.
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Dependency
    (
    -- * Dependency resolution
      resolveDependencies
    , resolveDependenciesAux 
    -- * Utilities
19
    , depToUnresolvedDep
20
21
22
23
24
25
    , getPackages            -- :: [ResolvedPackage] -> [(PackageIdentifier,[String],String)]
    , getBuildDeps           -- :: [PackageIdentifier] -> [ResolvedPackage] -> [ResolvedPackage]
    , filterFetchables       -- :: [ResolvedPackage] -> [(PackageIdentifier,String)]
    , fulfillDependency      -- :: Dependency -> PackageIdentifier -> Bool
    ) where

26
import Distribution.Version (Version, Dependency(..), withinRange)
27
import Distribution.Package (PackageIdentifier(..))
28
import Distribution.PackageDescription 
bjorn@bringert.net's avatar
bjorn@bringert.net committed
29
    (PackageDescription(package, buildDepends)
30
31
    , GenericPackageDescription(packageDescription)
    , finalizePackageDescription)
32
import Distribution.ParseUtils (showDependency)
33
import Distribution.Simple.Compiler  (PackageDB(..), Compiler, showCompilerId, compilerVersion)
34
import Distribution.Simple.Program (ProgramConfiguration)
35

36
37
import Data.Char (toLower)
import Data.List (nub, maximumBy, isPrefixOf)
38
import qualified System.Info (arch,os)
39

40
import Network.Hackage.CabalInstall.Config (listInstalledPackages, getKnownPackages, findCompiler)
41
import Network.Hackage.CabalInstall.Types ( ResolvedPackage(..), UnresolvedDependency(..)
42
                                      , ConfigFlags (..), PkgInfo (..), ResolvedDependency(..), Repo(..))
43
44
45
46
47
48
49
50
51
import Text.Printf (printf)


-- |Flattens a list of dependencies, filtering out installed packages.
--  Packages dependencies are placed before the packages and duplicate entries
--  are removed.
flattenDepList :: [PackageIdentifier] -- ^List of installed packages.
               -> [ResolvedPackage] -- ^List of resolved packages.
               -> [ResolvedPackage]
bjorn@bringert.net's avatar
bjorn@bringert.net committed
52
53
flattenDepList ps
    = nub . filter (not . isInstalled ps . fulfilling) . concatMap flatten
54
    where flatten pkgInfo = getBuildDeps ps [pkgInfo] ++ [pkgInfo]
55

56
57
58
59
-- | Flattens a dependency list, keeping only the transitive closure of the 
--   dependencies of the top-level packages.
--   This is used for installing all the dependencies of set of packages but not the packages
--   themselves. Filters out installed packages and duplicates.
60
61
getBuildDeps :: [PackageIdentifier] -> [ResolvedPackage]
             -> [ResolvedPackage]
62
63
64
65
66
67
getBuildDeps ps
    = nub . filter (not . isInstalled ps . fulfilling) . concatMap flattenDeps
    where flattenDeps pkgInfo 
              = case resolvedData pkgInfo of
                  Just (_,_,subDeps) -> flattenDepList ps subDeps
                  Nothing            -> []
68
69
70
71
72
73
74
75
76
77
78
79
80

depToUnresolvedDep :: Dependency -> UnresolvedDependency
depToUnresolvedDep dep
    = UnresolvedDependency
      { dependency = dep
      , depOptions = [] }

resolvedDepToResolvedPkg :: (Dependency,Maybe ResolvedDependency) -> ResolvedPackage
resolvedDepToResolvedPkg (dep,rDep)
    = ResolvedPackage
      { fulfilling = dep
      , resolvedData = rData
      , pkgOptions = [] }
81
    where rData = do ResolvedDependency pkg repo subDeps <- rDep
82
                     return ( pkg
83
                            , repo
84
85
86
                            , map resolvedDepToResolvedPkg subDeps )


87
-- |Locates a @PkgInfo@ which satisfies a given @Dependency@.
88
--  Fails with "cannot satisfy dependency: %s." where %s == the given dependency.
89
getLatestPkg :: (Monad m) => [PkgInfo] -> Dependency -> m PkgInfo
90
getLatestPkg ps dep
91
    = case filter (fulfillDependency dep . pkdId) ps of
92
        [] -> fail $ printf "cannot satisfy dependency: %s." (show (showDependency dep))
93
        qs -> return $ maximumBy compareVersions qs
94
  where compareVersions a b = pkgVersion (pkdId a) `compare` pkgVersion (pkdId b)
95
        pkdId = package . packageDescription . pkgDesc
96
97
98
99
100
101

-- |Evaluates to @True@ if the given @Dependency@ is satisfied by the given @PackageIdentifer@.
fulfillDependency :: Dependency -> PackageIdentifier -> Bool
fulfillDependency (Dependency depName vrange) pkg
    = pkgName pkg == depName && pkgVersion pkg `withinRange` vrange

102
103
104
105
106
107
108
-- | Checks whether there is an installed package that satisfies the
--   given dependency.
isInstalled :: [PackageIdentifier] -- ^Installed packages.
            -> Dependency -> Bool
isInstalled ps dep = any (fulfillDependency dep) ps


109
getDependency :: Compiler
110
              -> [PackageIdentifier]
111
              -> [PkgInfo]
112
              -> UnresolvedDependency -> ResolvedPackage
113
getDependency comp installed available (UnresolvedDependency { dependency=dep, depOptions=opts})
114
    = ResolvedPackage { fulfilling = dep
115
                      , resolvedData = fmap pkgData (getLatestPkg available dep)
116
                      , pkgOptions = opts }
117
118
    where pkgData p = ( package d
                      , pkgRepo p
119
120
                      , map (getDependency comp installed available . depToUnresolvedDep) (buildDepends d))
             where d = finalizePackage comp installed available (configurationsFlags opts) p
121
122
123
124
125
126
127
128
129
130
131

configurationsFlags :: [String] -> [(String, Bool)]
configurationsFlags opts = 
    case filter ("--flags=" `isPrefixOf`) opts of
      [] -> []
      xs -> flagList $ removeQuotes $ drop 8 $ last xs
  where removeQuotes ('"':s) = take (length s - 1) s
        removeQuotes s = s
        flagList = map tagWithValue . words
            where tagWithValue ('-':name) = (map toLower name, False)
                  tagWithValue name       = (map toLower name, True)
132
133
134

-- |Get the PackageIdentifier, build options and location from a list of resolved packages.
--  Throws an exception if a package couldn't be resolved.
135
getPackages :: [ResolvedPackage] -> [(PackageIdentifier,[String],Repo)]
136
137
138
139
140
getPackages = map worker
    where worker dep
              = case resolvedData dep of
                  Nothing
                      -> error $ printf "Couldn't satisfy dependency: '%s'." (show $ showDependency (fulfilling dep))
141
142
                  Just (pkg,repo,_)
                      -> (pkg,pkgOptions dep,repo)
143
144

-- |List all packages which can be fetched.
145
filterFetchables :: [ResolvedPackage] -> [(PackageIdentifier,Repo)]
bjorn@bringert.net's avatar
bjorn@bringert.net committed
146
filterFetchables pkgs = [(pkg,repo) | Just (pkg,repo,_) <- map resolvedData pkgs]
147

148
finalizePackage :: Compiler 
149
                -> [PackageIdentifier] -- ^ All installed packages
150
                -> [PkgInfo] -- ^  All available packages
151
                -> [(String,Bool)] -- ^ Configurations flags
152
                -> PkgInfo
153
                -> PackageDescription
154
finalizePackage comp installed available flags desc
155
156
157
158
159
    = case e of
        Left missing -> error $ "Can't resolve dependencies: " ++ show missing
        Right (d,flags) -> d
  where 
    e = finalizePackageDescription 
160
          flags
161
          (Just $ nub $ installed ++ map (package . packageDescription . pkgDesc) available) 
162
163
          System.Info.os
          System.Info.arch
164
          (showCompilerId comp, compilerVersion comp)
165
          (pkgDesc desc)
166
167
168
169

-- |Resolve some dependencies from the known packages while filtering out installed packages.
--  The result hasn't been modified to put the dependencies in front of the packages.
resolveDependenciesAux :: ConfigFlags
170
171
                       -> Compiler
                       -> ProgramConfiguration
172
                       -> [PackageIdentifier] -- ^Installed packages.
173
                       -> [PkgInfo] -- ^ Installable packages
174
                       -> [UnresolvedDependency] -- ^Dependencies in need of resolution.
175
176
177
178
179
                       -> [ResolvedPackage]
resolveDependenciesAux cfg comp conf installed available deps
    = map resolve (filter (not . isInstalled installed . dependency) deps)
  where resolve dep
              = let rDep = getDependency comp installed available dep
180
181
182
                in case resolvedData rDep of
                    Nothing -> resolvedDepToResolvedPkg (dependency dep,Nothing)
                    _ -> rDep
183

bjorn@bringert.net's avatar
bjorn@bringert.net committed
184

185
186
187
-- |Resolve some dependencies from the known packages while filtering out installed packages.
--  The result has been modified to put the dependencies in front of the packages.
resolveDependencies :: ConfigFlags
188
189
                    -> Compiler
                    -> ProgramConfiguration
190
191
                    -> [UnresolvedDependency] -- ^Dependencies in need of resolution.
                    -> IO [ResolvedPackage]
192
193
resolveDependencies cfg comp conf deps
    = do installed <- listInstalledPackages cfg comp conf
194
195
         available <- getKnownPackages cfg
         return $ flattenDepList installed $ resolveDependenciesAux cfg comp conf installed available deps