summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2014-04-05 09:11:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-05 09:11:00 (GMT)
commit7d4d9979d692d3acf3b349d7a3e958dd032c9c83 (patch)
tree23e9ff5983ba376c7ebd9437969c8b832b448e58
parente1ae8d1031ad5b6553eda5c19aff4250197775a9 (diff)
version 0.40.4
-rw-r--r--BlingBling.hs52
-rw-r--r--Cabal2Ebuild.hs9
-rw-r--r--Merge.hs145
-rw-r--r--Merge/Dependencies.hs40
-rw-r--r--Portage/Cabal.hs11
-rw-r--r--Portage/Dependency.hs73
-rw-r--r--Portage/Dependency/Builder.hs12
-rw-r--r--Portage/Dependency/Normalize.hs354
-rw-r--r--Portage/Dependency/Print.hs38
-rw-r--r--Portage/Dependency/Types.hs94
-rw-r--r--Portage/EBuild.hs3
-rw-r--r--Portage/GHCCore.hs55
-rw-r--r--Portage/Use.hs43
-rw-r--r--hackport.cabal3
-rwxr-xr-xmk_release_tarball.bash4
-rw-r--r--tests/normalize_deps.hs81
-rw-r--r--tests/print_deps.hs10
17 files changed, 531 insertions, 496 deletions
diff --git a/BlingBling.hs b/BlingBling.hs
deleted file mode 100644
index 23ad2ff..0000000
--- a/BlingBling.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-module BlingBling where
-
-import qualified Progress
-
-import System.IO
-import Control.Exception as Exception (bracket)
-
--- what nobody needs but everyone wants...
-
--- FIXME: do something more fun here
-forMbling :: [a] -> (a -> IO b) -> IO [b]
-forMbling lst f =
- withBuffering stdout NoBuffering $ do
- xs <- mapM (\x -> putStr "." >> f x) lst
- putStrLn ""
- return xs
-
-blingProgress :: Progress.Progress s String a -> IO a
-blingProgress progress = do
- isTerm <- hIsTerminalDevice stdout
- if isTerm
- then canIHasTehBling
- else boring
-
- where
- boring = Progress.fold (flip const) fail return progress
-
- canIHasTehBling =
- withBuffering stdout NoBuffering $ do
- putChar (fst (char 0))
- result <- spin 0 progress
- putStr "\b \b"
- return result
-
- spin _ (Progress.Fail e) = fail e
- spin _ (Progress.Done r) = return r
- spin n (Progress.Step _ p) = do
- putStr ['\b', c]
- spin n' p
- where (c, n') = char n
-
- char :: Int -> (Char, Int)
- char 0 = ('/', 1)
- char 1 = ('-', 2)
- char 2 = ('\\', 3)
- char _ = ('|', 0)
-
-withBuffering :: Handle -> BufferMode -> IO a -> IO a
-withBuffering hnd mode action =
- Exception.bracket
- (hGetBuffering hnd) (hSetBuffering hnd)
- (\_ -> hSetBuffering hnd mode >> action)
diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs
index eef91b4..e465fc9 100644
--- a/Cabal2Ebuild.hs
+++ b/Cabal2Ebuild.hs
@@ -29,8 +29,7 @@ module Cabal2Ebuild
import qualified Distribution.PackageDescription as Cabal
(PackageDescription(..))
import qualified Distribution.Package as Cabal (PackageIdentifier(..)
- , Dependency(..)
- , PackageName(..))
+ , Dependency(..))
import qualified Distribution.Version as Cabal (VersionRange, foldVersionRange')
import Distribution.Text (display)
@@ -40,7 +39,6 @@ import Portage.Dependency
import qualified Portage.Cabal as Portage
import qualified Portage.PackageId as Portage
import qualified Portage.EBuild as Portage
-import qualified Portage.GHCCore as Portage
import qualified Portage.Resolve as Portage
import qualified Portage.EBuild as E
import qualified Portage.Overlay as O
@@ -78,11 +76,6 @@ convertDependencies :: O.Overlay -> Portage.Category -> [Cabal.Dependency] -> [D
convertDependencies overlay category = map (convertDependency overlay category)
convertDependency :: O.Overlay -> Portage.Category -> Cabal.Dependency -> Dependency
-convertDependency _overlay _category (Cabal.Dependency pname@(Cabal.PackageName _name) _)
- -- no explicit dep on core libs.
- -- TODO: the same is done when filtering in
- -- merge phase in a more robust way. Do we need it?
- | pname `elem` Portage.coreLibs = empty_dependency
convertDependency overlay category (Cabal.Dependency pname versionRange)
= convert versionRange
where
diff --git a/Merge.hs b/Merge.hs
index 4331626..057af84 100644
--- a/Merge.hs
+++ b/Merge.hs
@@ -12,6 +12,7 @@ import Data.Function (on)
import Data.Maybe
import Data.Monoid
import qualified Data.List as L
+import qualified Data.Set as S
import qualified Data.Time.Clock as TC
import Data.Version
@@ -52,12 +53,14 @@ import Error as E
import Network.URI
+import qualified Portage.Cabal as Portage
import qualified Portage.PackageId as Portage
import qualified Portage.Version as Portage
import qualified Portage.Metadata as Portage
import qualified Portage.Overlay as Overlay
import qualified Portage.Resolve as Portage
import qualified Portage.Dependency as Portage
+import qualified Portage.Use as Portage
import qualified Portage.GHCCore as GHCCore
@@ -163,11 +166,7 @@ merge verbosity repo _serverURI args overlayPath users_cabal_flags = do
mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True users_cabal_flags
first_just_of :: [Maybe a] -> Maybe a
-first_just_of [] = Nothing
-first_just_of (m:ms) =
- case m of
- Nothing -> first_just_of ms
- Just _ -> m
+first_just_of = msum
mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO ()
mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do
@@ -178,8 +177,35 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
existing_meta <- EM.findExistingMeta pkgdir
let requested_cabal_flags = first_just_of [users_cabal_flags, EM.cabal_flags existing_meta]
+ -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag"
+ read_fas :: Maybe String -> (Cabal.FlagAssignment, [(String, String)])
+ read_fas Nothing = ([], [])
+ read_fas (Just user_fas_s) = (user_fas, user_renames)
+ where user_fas = [ (cf, b)
+ | ((cf, _), Just b) <- cn_in_mb
+ ]
+ user_renames = [ (cfn, ein)
+ | ((Cabal.FlagName cfn, ein), Nothing) <- cn_in_mb
+ ]
+ cn_in_mb = map read_fa $ U.split (== ',') user_fas_s
+ read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)
+ read_fa [] = error $ "read_fas: empty flag?"
+ read_fa (op:flag) =
+ case op of
+ '+' -> (get_rename flag, Just True)
+ '-' -> (get_rename flag, Just False)
+ _ -> (get_rename (op:flag), Nothing)
+ where get_rename :: String -> (Cabal.FlagName, String)
+ get_rename s =
+ case U.split (== ':') s of
+ [cabal_flag_name] -> (Cabal.FlagName cabal_flag_name, cabal_flag_name)
+ [cabal_flag_name, iuse_name] -> (Cabal.FlagName cabal_flag_name, iuse_name)
+ _ -> error $ "get_rename: too many components" ++ show (s)
+
+ (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags
+
debug verbosity "searching for minimal suitable ghc version"
- (compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc of
+ (compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc user_specified_fas of
Just v -> return v
Nothing -> let pn = display merged_cabal_pkg_name
cn = display cat
@@ -191,12 +217,10 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
, " $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal"
]
- -- , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd g)]
- let (accepted_deps, skipped_deps, dropped_deps) = partition_depends (Cabal.buildDepends pkgDesc0)
+ let (accepted_deps, skipped_deps) = Portage.partition_depends ghc_packages merged_cabal_pkg_name (Cabal.buildDepends pkgDesc0)
pkgDesc = pkgDesc0 { Cabal.buildDepends = accepted_deps }
cabal_flag_descs = Cabal.genPackageFlags pkgGenericDesc
all_flags = map Cabal.flagName cabal_flag_descs
- (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags
make_fas :: [Cabal.Flag] -> [Cabal.FlagAssignment]
make_fas [] = [[]]
make_fas (f:rest) = [ (fn, is_enabled) : fas
@@ -215,30 +239,6 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
| (Cabal.FlagName f, b) <- fa
]
- -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag"
- read_fas :: Maybe String -> (Cabal.FlagAssignment, [(String, String)])
- read_fas Nothing = ([], [])
- read_fas (Just user_fas_s) = (user_fas, user_renames)
- where user_fas = [ (cf, b)
- | ((cf, _), Just b) <- cn_in_mb
- ]
- user_renames = [ (cfn, ein)
- | ((Cabal.FlagName cfn, ein), Nothing) <- cn_in_mb
- ]
- cn_in_mb = map read_fa $ U.split (== ',') user_fas_s
- read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)
- read_fa [] = error $ "read_fas: empty flag?"
- read_fa (op:flag) =
- case op of
- '+' -> (get_rename flag, Just True)
- '-' -> (get_rename flag, Just False)
- _ -> (get_rename (op:flag), Nothing)
- where get_rename :: String -> (Cabal.FlagName, String)
- get_rename s =
- case U.split (== ':') s of
- [cabal_flag_name] -> (Cabal.FlagName cabal_flag_name, cabal_flag_name)
- [cabal_flag_name, iuse_name] -> (Cabal.FlagName cabal_flag_name, iuse_name)
- _ -> error $ "get_rename: too many components" ++ show (s)
cfn_to_iuse :: String -> String
cfn_to_iuse cfn =
@@ -257,7 +257,7 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
[]
pkgGenericDesc]
-- drop circular deps and shipped deps
- , let (ad, _sd, _rd) = partition_depends (Cabal.buildDepends pkgDesc1)
+ , let (ad, _sd) = Portage.partition_depends ghc_packages merged_cabal_pkg_name (Cabal.buildDepends pkgDesc1)
-- TODO: drop ghc libraries from tests depends as well
-- (see deepseq in hackport-0.3.5 as an example)
, let pkgDesc_filtered_bdeps = pkgDesc1 { Cabal.buildDepends = ad }
@@ -292,46 +292,57 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
, Merge.rdep = optimize_fa_depends $ map (second Merge.rdep) deps1
}
- pop_common_deps :: [FlagDepH] -> FlagDepH
+ pop_common_deps :: [(FaDep,[FaDep])] -> (FaDep,[FaDep])
pop_common_deps xs =
case pop_from_pairs xs of
[] -> error "impossible"
[x] -> x
r -> pop_common_deps r
where
- pop_from_pairs :: [FlagDepH] -> [FlagDepH]
+ pop_from_pairs :: [(FaDep,[FaDep])] -> [(FaDep,[FaDep])]
pop_from_pairs [] = []
pop_from_pairs [y] = [y]
pop_from_pairs (y1:y2:rest) = y1 `pop_from_pair` y2 : pop_from_pairs rest
- pop_from_pair :: FlagDepH -> FlagDepH -> FlagDepH
+ pop_from_pair :: (FaDep,[FaDep]) -> (FaDep,[FaDep]) -> (FaDep,[FaDep])
pop_from_pair ((lfa, ld), lx) ((rfa, rd), rx) = ((fa, d), x)
where fa = lfa `L.intersect` rfa
- d = Portage.simplify_deps $ ld `L.intersect` rd
- x = (lfa, ld L.\\ rd)
- : (rfa, rd L.\\ ld)
+ d = ld `L.intersect` rd
+ x = (lfa, ld L.\\ d)
+ : (rfa, rd L.\\ d)
: lx ++ rx
- simplify :: [FlagDepH] -> [Portage.Dependency]
+ simplify :: [(FaDep,[FaDep])] -> [Portage.Dependency]
simplify fdephs =
let -- extract common part of the depends
-- filtering out empty groups
((common_fas, common_fdeps), all_fdeps) = second (filter (not . null . snd)) $ pop_common_deps fdephs
- -- Regroup flags according to packages, i.e.
- -- if 2 groups of flagged deps containg same package, then
- -- extract common flags, but if common flags will be empty
- -- then remove repacked package from the result list.
- -- This is simplify packages but will not break if depend
- -- is required but non intersecting groups.
+ -- apply assumption of 'fdep' on other depends
+ -- Handle at least:
+ -- 1. redundant-USE cancelation
+ -- a? b? c? ( x ) a? ( x ) => a? ( x )
+ -- 2. one-USE irrelevance
+ -- a? b? c? d? ( x ) a? b? !c? d? ( x ) => a? b? d? ( x )
+ -- Ideally this thing should be multipass
mergeD :: (Cabal.FlagAssignment, Portage.Dependency)
-> [(Cabal.FlagAssignment, Portage.Dependency)]
-> [(Cabal.FlagAssignment, Portage.Dependency)]
mergeD fdep [] = [fdep]
mergeD lfdep@(lfa, ld) (rfdep@(rfa, rd):rest) =
- case (ld == rd, lfa `L.intersect` rfa) of
- (True, []) -> rest
- (True, c_fa) -> (c_fa, ld):rest
- (False, _) -> rfdep:mergeD lfdep rest
+ case (ld == rd, slfa `S.intersection` srfa) of
+ -- [1]
+ (True, ifa) | ifa == slfa || ifa == srfa
+ -> mergeD (S.toList ifa, ld) rest
+ -- [2]
+ (True, ifa) | case (S.toList (slfa S.\\ ifa), S.toList (srfa S.\\ ifa)) of
+ ([(lfn, lfv)], [(rfn, rfv)])
+ -> lfn == rfn && lfv == not rfv
+ _ -> False
+ -> mergeD (S.toList ifa, ld) rest
+ -- otherwise
+ _ -> rfdep:mergeD lfdep rest
+ where slfa = S.fromList lfa
+ srfa = S.fromList rfa
sd :: [(Cabal.FlagAssignment, [Portage.Dependency])]
sd = M.toList $!
@@ -342,7 +353,9 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
in M.alter push_front fa fadeps
) M.empty $ L.foldl' (\fadeps fadep -> fadep `mergeD` fadeps)
[]
- (concatMap (\(fa, deps) -> map (\one_dep -> (fa, one_dep)) deps) all_fdeps)
+ (concatMap (\(fa, deps) -> map (\one_dep -> (fa, one_dep))
+ deps)
+ all_fdeps)
-- filter out splitted packages from common group
ys = filter (not.null.snd) $ map (second (filter (\d -> d `notElem` concatMap snd sd)
)) all_fdeps
@@ -359,35 +372,25 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
else liftFlags [u] (simplify $ map (\x -> (x,[])) $ dropFlag u fdeps_u) ++ simplifyMore fdeps_nu
in liftFlags common_fas common_fdeps ++ simplifyMore (sd ++ ys)
- get_fa_hist :: [FlagDep] -> [((Cabal.FlagName,Bool),Int)]
+ get_fa_hist :: [FaDep] -> [((Cabal.FlagName,Bool),Int)]
get_fa_hist fdeps = reverse $! L.sortBy (compare `on` snd) $!
M.toList $!
go M.empty (concatMap fst fdeps)
where go hist [] = hist
go hist (fd:fds) = go (M.insertWith (+) fd 1 hist) fds
-- drop selected use flag from a list
- dropFlag :: (Cabal.FlagName,Bool) -> [FlagDep] -> [FlagDep]
+ dropFlag :: (Cabal.FlagName,Bool) -> [FaDep] -> [FaDep]
dropFlag f = map (first (filter (f /=)))
- hasFlag :: (Cabal.FlagName,Bool) -> FlagDep -> Bool
+ hasFlag :: (Cabal.FlagName,Bool) -> FaDep -> Bool
hasFlag u = elem u . fst
liftFlags :: Cabal.FlagAssignment -> [Portage.Dependency] -> [Portage.Dependency]
- liftFlags fs e = let k = foldr (\(y,b) x -> Portage.DependIfUse (Portage.DUse (b, cfn_to_iuse $ unFlagName y)) . x)
+ liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . unFlagName $ y) . x)
id fs
- in Portage.simplify_deps [k $! Portage.DependAllOf e]
-
- partition_depends :: [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency], [Cabal.Dependency])
- partition_depends =
- L.foldl' (\(ad, sd, rd) (Cabal.Dependency pn vr) ->
- let dep = Cabal.Dependency pn (Cabal.simplifyVersionRange vr)
- in case () of
- _ | pn `elem` ghc_packages -> ( ad, dep:sd, rd)
- _ | pn == merged_cabal_pkg_name -> ( ad, sd, dep:rd)
- _ -> (dep:ad, sd, rd)
- )
- ([],[],[])
+ in [k $! Portage.DependAllOf e]
+
cabal_to_emerge_dep :: Cabal.PackageDescription -> Merge.EDep
- cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg (Just compilerId)
+ cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compilerId ghc_packages merged_cabal_pkg_name
debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0
debug verbosity $ "buildDepends pkgDesc0: " ++ show (map display (Cabal.buildDepends pkgDesc0))
@@ -395,7 +398,6 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
notice verbosity $ "Accepted depends: " ++ show (map display accepted_deps)
notice verbosity $ "Skipped depends: " ++ show (map display skipped_deps)
- notice verbosity $ "Dropped depends: " ++ show (map display dropped_deps)
notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments)
notice verbosity $ "Dropped flags: " ++ show (map (unFlagName.fst) common_fa)
-- mapM_ print tdeps
@@ -512,5 +514,4 @@ mergeEbuild verbosity existing_meta pkgdir ebuild = do
unFlagName :: Cabal.FlagName -> String
unFlagName (Cabal.FlagName fname) = fname
-type FlagDep = (Cabal.FlagAssignment,[Portage.Dependency])
-type FlagDepH = (FlagDep,[FlagDep])
+type FaDep = (Cabal.FlagAssignment, [Portage.Dependency])
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
index fda6cf6..59496e6 100644
--- a/Merge/Dependencies.hs
+++ b/Merge/Dependencies.hs
@@ -72,6 +72,7 @@ import qualified Distribution.Version as Cabal
import Distribution.Compiler
+import qualified Portage.Cabal as Portage
import qualified Portage.Dependency as Portage
import qualified Portage.Overlay as Portage
import qualified Portage.PackageId as Portage
@@ -101,9 +102,9 @@ instance Monoid EDep where
dep_e = []
}
(EDep rdepA rdep_eA depA dep_eA) `mappend` (EDep rdepB rdep_eB depB dep_eB) = EDep
- { rdep = Portage.simplify_deps $ rdepA ++ rdepB
+ { rdep = rdepA ++ rdepB
, rdep_e = S.toList $ (S.fromList rdep_eA) `S.union` (S.fromList rdep_eB)
- , dep = Portage.simplify_deps $ depA ++ depB
+ , dep = depA ++ depB
, dep_e = S.toList $ (S.fromList dep_eA) `S.union` (S.fromList dep_eB)
}
@@ -124,8 +125,10 @@ difference (EDep a1 a2 a3 a4) (EDep b1 b2 b3 b4) = EDep (f a1 b1)
null :: EDep -> Bool
null e = e == mempty
-resolveDependencies :: Portage.Overlay -> PackageDescription -> Maybe CompilerId -> EDep
-resolveDependencies overlay pkg mcompiler =
+resolveDependencies :: Portage.Overlay -> PackageDescription -> CompilerId
+ -> [Cabal.PackageName] -> Cabal.PackageName
+ -> EDep
+resolveDependencies overlay pkg compiler ghc_package_names merged_cabal_pkg_name =
edeps
{
dep = dep2,
@@ -134,11 +137,10 @@ resolveDependencies overlay pkg mcompiler =
-- version as in dep
}
where
- dep1 = Portage.simplify_deps ( dep edeps)
- dep2 = Portage.simplifyUseDeps dep1 (dep1++rdep2)
- rdep1 = Portage.simplify_deps (rdep edeps)
+ dep1 = dep edeps
+ dep2 = Portage.simplifyUseDeps dep1 (dep1 ++ rdep2)
+ rdep1 = rdep edeps
rdep2 = Portage.simplifyUseDeps rdep1 rdep1
- compiler = maybe (fst GHCCore.defaultGHC) id mcompiler
-- hasBuildableExes p = any (buildable . buildInfo) . executables $ p
treatAsLibrary = isJust (Cabal.library pkg)
@@ -146,7 +148,7 @@ resolveDependencies overlay pkg mcompiler =
| treatAsLibrary = map set_build_slot $ map add_profile $ haskellDependencies overlay (buildDepends pkg)
| otherwise = haskellDependencies overlay (buildDepends pkg)
test_deps
- | (not . L.null) (testSuites pkg) = testDependencies overlay pkg
+ | (not . L.null) (testSuites pkg) = testDependencies overlay pkg ghc_package_names merged_cabal_pkg_name
| otherwise = [] -- tests not enabled
cabal_dep = cabalDependency overlay pkg compiler
ghc_dep = compilerIdToDependency compiler
@@ -178,18 +180,18 @@ resolveDependencies overlay pkg mcompiler =
dep_e = [ "${RDEPEND}" ],
rdep = extra_libs ++ pkg_config_libs
}
- add_profile = Portage.addDepUseFlag (Portage.mkQUse "profile")
+ add_profile = Portage.addDepUseFlag (Portage.mkQUse (Portage.Use "profile"))
set_build_slot = Portage.setSlotDep Portage.AnyBuildTimeSlot
---------------------------------------------------------------
-- Test-suite dependencies
---------------------------------------------------------------
-testDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]
-testDependencies overlay pkg@(PackageDescription { package = Cabal.PackageIdentifier { Cabal.pkgName = Cabal.PackageName name}}) =
- [Portage.DependIfUse (Portage.DUse (True, "test")) (Portage.DependAllOf $ Portage.simplify_deps deps)]
+testDependencies :: Portage.Overlay -> PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency]
+testDependencies overlay pkg ghc_package_names merged_cabal_pkg_name =
+ [Portage.mkUseDependency (True, Portage.Use "test") (Portage.DependAllOf deps)]
where cabalDeps = concat $ map targetBuildDepends $ map testBuildInfo (testSuites pkg)
- cabalDeps' = filter (\(Cabal.Dependency (Cabal.PackageName pname) _) -> pname /= name) cabalDeps
+ cabalDeps' = fst $ Portage.partition_depends ghc_package_names merged_cabal_pkg_name cabalDeps
deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps'
---------------------------------------------------------------
@@ -198,8 +200,7 @@ testDependencies overlay pkg@(PackageDescription { package = Cabal.PackageIdenti
haskellDependencies :: Portage.Overlay -> [Cabal.Dependency] {- PackageDescription -} -> [Portage.Dependency]
haskellDependencies overlay deps =
- Portage.simplify_deps
- $ C2E.convertDependencies overlay (Portage.Category "dev-haskell") deps
+ C2E.convertDependencies overlay (Portage.Category "dev-haskell") deps
---------------------------------------------------------------
-- Cabal Dependency
@@ -208,7 +209,7 @@ haskellDependencies overlay deps =
-- | Select the most restrictive dependency on Cabal, either the .cabal
-- file's descCabalVersion, or the Cabal GHC shipped with.
cabalDependency :: Portage.Overlay -> PackageDescription -> CompilerId -> Portage.Dependency
-cabalDependency overlay pkg (CompilerId GHC _ghcVersion@(Cabal.Version versionNumbers _)) =
+cabalDependency overlay pkg ~(CompilerId GHC _ghcVersion@(Cabal.Version versionNumbers _)) =
C2E.convertDependency overlay
(Portage.Category "dev-haskell")
(Cabal.Dependency (Cabal.PackageName "Cabal")
@@ -227,7 +228,7 @@ cabalDependency overlay pkg (CompilerId GHC _ghcVersion@(Cabal.Version versionNu
---------------------------------------------------------------
compilerIdToDependency :: CompilerId -> Portage.Dependency
-compilerIdToDependency (CompilerId GHC versionNumbers) =
+compilerIdToDependency ~(CompilerId GHC versionNumbers) =
at_least_c_p_v "dev-lang" "ghc" (Cabal.versionBranch versionNumbers)
---------------------------------------------------------------
@@ -292,7 +293,7 @@ staticTranslateExtraLib lib = lookup lib m
, ("m", any_c_p "virtual" "libc")
, ("asound", any_c_p "media-libs" "alsa-lib")
, ("sqlite3", at_least_c_p_v "dev-db" "sqlite" [3,0])
- , ("stdc++", any_c_p_s_u "sys-devel" "gcc" Portage.AnySlot [Portage.mkUse "cxx"])
+ , ("stdc++", any_c_p_s_u "sys-devel" "gcc" Portage.AnySlot [Portage.mkUse (Portage.Use "cxx")])
, ("crack", any_c_p "sys-libs" "cracklib")
, ("exif", any_c_p "media-libs" "libexif")
, ("IL", any_c_p "media-libs" "devil")
@@ -335,6 +336,7 @@ staticTranslateExtraLib lib = lookup lib m
, ("alut", any_c_p "media-libs" "freealut")
, ("openal", any_c_p "media-libs" "openal")
, ("iw", any_c_p "net-wireless" "wireless-tools")
+ , ("attr", any_c_p "sys-apps" "attr")
]
---------------------------------------------------------------
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
index fa9a21c..231a732 100644
--- a/Portage/Cabal.hs
+++ b/Portage/Cabal.hs
@@ -1,12 +1,16 @@
module Portage.Cabal
( fromOverlay
, convertLicense
+ , partition_depends
) where
+import qualified Data.List as L
import qualified Data.Map as Map
import qualified Distribution.Client.PackageIndex as Cabal
import qualified Distribution.License as Cabal
+import qualified Distribution.Package as Cabal
+import qualified Distribution.Version as Cabal
import qualified Distribution.Text as Cabal
import qualified Portage.Overlay as Portage
@@ -35,3 +39,10 @@ convertLicense l =
Cabal.AllRightsReserved -> Left "EULA-style licence. Please pick it manually."
Cabal.UnknownLicense _ -> Left "license unknown to cabal. Please pick it manually."
Cabal.OtherLicense -> Left "Please look at license file of package and pick it manually."
+
+partition_depends :: [Cabal.PackageName] -> Cabal.PackageName -> [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency])
+partition_depends ghc_package_names merged_cabal_pkg_name = L.partition (not . is_internal_depend)
+ where is_internal_depend (Cabal.Dependency pn vr) = is_itself || is_ghc_package
+ where dep = Cabal.Dependency pn (Cabal.simplifyVersionRange vr)
+ is_itself = pn == merged_cabal_pkg_name
+ is_ghc_package = pn `elem` ghc_package_names
diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs
index 6df98bc..b53770f 100644
--- a/Portage/Dependency.hs
+++ b/Portage/Dependency.hs
@@ -1,7 +1,6 @@
module Portage.Dependency
(
- simplify_deps
- , simplifyUseDeps
+ simplifyUseDeps
, sortDeps
-- reexports
@@ -11,9 +10,8 @@ module Portage.Dependency
) where
import Data.Function ( on )
-import Data.List ( nub, groupBy, partition, sortBy )
+import Data.List ( partition, sortBy )
import Data.Maybe ( fromJust, mapMaybe )
-import Data.Ord ( comparing )
import Portage.PackageId
@@ -21,51 +19,11 @@ import Portage.Dependency.Builder
import Portage.Dependency.Print
import Portage.Dependency.Types
-mergeDRanges :: DRange -> DRange -> DRange
-mergeDRanges _ r@(DExact _) = r
-mergeDRanges l@(DExact _) _ = l
-mergeDRanges (DRange ll lu) (DRange rl ru) = DRange (max ll rl) (min lu ru)
-
-merge_pair :: Dependency -> Dependency -> Dependency
-merge_pair (Atom lp ld la) (Atom rp rd ra)
- | lp /= rp = error "merge_pair got different 'PackageName's"
- | la /= ra = error "merge_pair got different 'DAttr's"
- | otherwise = Atom lp (mergeDRanges ld rd) la
-merge_pair l r = error $ unwords ["merge_pair can't merge non-atoms:", show l, show r]
-
--- TODO: remove it in favour of more robust 'normalize_depend'
-simplify_group :: [Dependency] -> Dependency
-simplify_group [x] = x
-simplify_group xs = foldl1 merge_pair xs
-
--- TODO: remove it in favour of more robust 'normalize_depend'
--- divide packages to groups (by package name), simplify groups, merge again
-simplify_deps :: [Dependency] -> [Dependency]
-simplify_deps deps = flattenDep $
- (map (simplify_group.nub) $
- groupBy cmpPkgName $
- sortBy (comparing getPackagePart) groupable)
- ++ ungroupable
- where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps
- --
- cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)
- cmpMaybe (Just p1) (Just p2) = p1 == p2
- cmpMaybe _ _ = False
- --
- flattenDep :: [Dependency] -> [Dependency]
- flattenDep [] = []
- flattenDep (DependAllOf ds:xs) = (concatMap (\x -> flattenDep [x]) ds) ++ flattenDep xs
- flattenDep (x:xs) = x:flattenDep xs
- -- TODO concat 2 dep either in the same group
-
getPackage :: Dependency -> Maybe PackageName
getPackage (DependAllOf _dependency) = Nothing
getPackage (Atom pn _dr _attrs) = Just pn
getPackage (DependAnyOf _dependency ) = Nothing
-getPackage (DependIfUse _useFlag _Dependency) = Nothing
-
-getPackagePart :: Dependency -> PackageName
-getPackagePart dep = fromJust (getPackage dep)
+getPackage (DependIfUse _useFlag _td _fd) = Nothing
-- | remove all Use dependencies that overlap with normal dependencies
simplifyUseDeps :: [Dependency] -- list where use deps is taken
@@ -77,7 +35,12 @@ simplifyUseDeps ds cs =
in (mapMaybe (intersectD c) u)++o
intersectD :: [PackageName] -> Dependency -> Maybe Dependency
-intersectD fs (DependIfUse u d) = intersectD fs d >>= Just . DependIfUse u
+intersectD fs (DependIfUse u td fd) =
+ case (intersectD fs td, intersectD fs fd) of
+ (Nothing, Nothing) -> Nothing
+ (Just td', Nothing) -> Just $ DependIfUse u td' empty_dependency
+ (Nothing, Just fd') -> Just $ DependIfUse u empty_dependency fd'
+ (Just td', Just fd') -> Just $ DependIfUse u td' fd'
intersectD fs (DependAnyOf ds) =
let ds' = mapMaybe (intersectD fs) ds
in if null ds' then Nothing else Just (DependAnyOf ds')
@@ -89,7 +52,7 @@ intersectD fs x =
in if any (==pkg) fs then Nothing else Just x
isUseDep :: Dependency -> Bool
-isUseDep (DependIfUse _ _) = True
+isUseDep (DependIfUse _ _ _) = True
isUseDep _ = False
@@ -97,23 +60,23 @@ sortDeps :: [Dependency] -> [Dependency]
sortDeps = sortBy dsort . map deeper
where
deeper :: Dependency -> Dependency
- deeper (DependIfUse u1 d) = DependIfUse u1 $ deeper d
+ deeper (DependIfUse u1 td fd) = DependIfUse u1 (deeper td) (deeper fd)
deeper (DependAllOf ds) = DependAllOf $ sortDeps ds
deeper (DependAnyOf ds) = DependAnyOf $ sortDeps ds
deeper x = x
dsort :: Dependency -> Dependency -> Ordering
- dsort (DependIfUse u1 _) (DependIfUse u2 _) = u1 `compare` u2
- dsort (DependIfUse _ _) (DependAnyOf _) = LT
- dsort (DependIfUse _ _) (DependAllOf _) = LT
- dsort (DependIfUse _ _) _ = GT
+ dsort (DependIfUse u1 _ _) (DependIfUse u2 _ _) = u1 `compare` u2
+ dsort (DependIfUse _ _ _) (DependAnyOf _) = LT
+ dsort (DependIfUse _ _ _) (DependAllOf _) = LT
+ dsort (DependIfUse _ _ _) _ = GT
dsort (DependAnyOf _) (DependAnyOf _) = EQ
- dsort (DependAnyOf _) (DependIfUse _ _) = GT
+ dsort (DependAnyOf _) (DependIfUse _ _ _) = GT
dsort (DependAnyOf _) (DependAllOf _) = LT
dsort (DependAnyOf _) _ = GT
dsort (DependAllOf _) (DependAllOf _) = EQ
- dsort (DependAllOf _) (DependIfUse _ _) = LT
+ dsort (DependAllOf _) (DependIfUse _ _ _) = LT
dsort (DependAllOf _) (DependAnyOf _) = GT
- dsort _ (DependIfUse _ _) = LT
+ dsort _ (DependIfUse _ _ _) = LT
dsort _ (DependAllOf _) = LT
dsort _ (DependAnyOf _) = LT
dsort a b = (compare `on` getPackage) a b
diff --git a/Portage/Dependency/Builder.hs b/Portage/Dependency/Builder.hs
index db2f3d1..7f5a7e0 100644
--- a/Portage/Dependency/Builder.hs
+++ b/Portage/Dependency/Builder.hs
@@ -4,11 +4,13 @@ module Portage.Dependency.Builder
empty_dependency
, addDepUseFlag
, setSlotDep
+ , mkUseDependency
) where
import Portage.Dependency.Types
import Portage.Use
+-- TODO: remove it and switch to 'SatisfiedDepend' instead
empty_dependency :: Dependency
empty_dependency = DependAllOf []
@@ -16,10 +18,16 @@ addDepUseFlag :: UseFlag -> Dependency -> Dependency
addDepUseFlag n (DependAllOf d) = DependAllOf $ map (addDepUseFlag n) d
addDepUseFlag n (Atom pn dr (DAttr s u)) = Atom pn dr (DAttr s (n:u))
addDepUseFlag n (DependAnyOf d) = DependAnyOf $ map (addDepUseFlag n) d
-addDepUseFlag n (DependIfUse u d) = DependIfUse u (addDepUseFlag n d)
+addDepUseFlag n (DependIfUse u td fd) = DependIfUse u (addDepUseFlag n td) (addDepUseFlag n fd)
setSlotDep :: SlotDepend -> Dependency -> Dependency
setSlotDep n (DependAllOf d) = DependAllOf $ map (setSlotDep n) d
setSlotDep n (Atom pn dr (DAttr _s u)) = Atom pn dr (DAttr n u)
setSlotDep n (DependAnyOf d) = DependAnyOf $ map (setSlotDep n) d
-setSlotDep n (DependIfUse u d) = DependIfUse u (setSlotDep n d)
+setSlotDep n (DependIfUse u td fd) = DependIfUse u (setSlotDep n td) (setSlotDep n fd)
+
+mkUseDependency :: (Bool, Use) -> Dependency -> Dependency
+mkUseDependency (b, u) d =
+ case b of
+ True -> DependIfUse u d empty_dependency
+ False -> DependIfUse u empty_dependency d
diff --git a/Portage/Dependency/Normalize.hs b/Portage/Dependency/Normalize.hs
index 401292d..b98c07d 100644
--- a/Portage/Dependency/Normalize.hs
+++ b/Portage/Dependency/Normalize.hs
@@ -3,37 +3,38 @@ module Portage.Dependency.Normalize
normalize_depend
) where
+import Control.Monad
import qualified Data.List as L
+import Data.Maybe
import Portage.Dependency.Types
+import Portage.Dependency.Builder
+import Portage.Use
+
+import Debug.Trace
mergeDRanges :: DRange -> DRange -> DRange
mergeDRanges _ r@(DExact _) = r
mergeDRanges l@(DExact _) _ = l
mergeDRanges (DRange ll lu) (DRange rl ru) = DRange (max ll rl) (min lu ru)
--- TODO: remove it and switch to 'SatisfiedDepend' instead
-empty_dependency :: Dependency
-empty_dependency = DependAllOf []
-
-is_empty_dependency :: Dependency -> Bool
-is_empty_dependency (DependIfUse _use dep) = is_empty_dependency dep
-is_empty_dependency (DependAnyOf []) = True -- because any (const True) == False
-is_empty_dependency (DependAnyOf deps) = any is_empty_dependency deps
-is_empty_dependency (DependAllOf deps) = all is_empty_dependency deps
-is_empty_dependency (Atom _pn _dr _dattr) = False
+stabilize_pass :: (Dependency -> Dependency) -> Dependency -> Dependency
+stabilize_pass pass d
+ | d == d' = d'
+ | otherwise = go d'
+ where go = stabilize_pass pass
+ d' = pass d
-- remove one layer of redundancy
normalization_step :: Dependency -> Dependency
normalization_step = combine_atoms
- . propagate_context
- . flatten
+ . stabilize_pass propagate_context
+ . stabilize_pass flatten
. lift_context
- . remove_duplicates
- . remove_empty
+ . stabilize_pass remove_duplicates
+ . stabilize_pass remove_empty
. sort_deps
. combine_use_guards
- . combine_use_counterguards
remove_empty :: Dependency -> Dependency
remove_empty d =
@@ -41,53 +42,69 @@ remove_empty d =
-- drop full empty nodes
_ | is_empty_dependency d -> empty_dependency
-- drop partial empty nodes
- (DependIfUse use dep) -> DependIfUse use $ remove_empty dep
- (DependAllOf deps) -> DependAllOf $ filter (not . is_empty_dependency) $ map remove_empty deps
- (DependAnyOf deps) -> DependAnyOf $ map remove_empty deps
+ DependIfUse use td fd -> DependIfUse use (go td) (go fd)
+ DependAllOf deps -> DependAllOf $ filter (not . is_empty_dependency) $ map go deps
+ DependAnyOf deps -> DependAnyOf $ map go deps
-- no change
- (Atom _pn _dr _dattr) -> d
+ Atom _pn _dr _dattr -> d
+ where go = remove_empty
-- Ideally 'combine_atoms' should handle those as well
remove_duplicates :: Dependency -> Dependency
remove_duplicates d =
case d of
- (DependIfUse use dep) -> (DependIfUse use $ remove_duplicates dep)
- (DependAnyOf deps) -> DependAnyOf $ L.nub $ map remove_duplicates deps
- (DependAllOf deps) -> DependAllOf $ L.nub $ map remove_duplicates deps
- (Atom _pn _dr _dattr) -> d
+ DependIfUse use td fd -> DependIfUse use (go td) (go fd)
+ DependAnyOf deps -> DependAnyOf $ L.nub $ map go deps
+ DependAllOf deps -> DependAllOf $ L.nub $ map go deps
+ Atom _pn _dr _dattr -> d
+ where go = remove_duplicates
--- TODO: implement flattening (if not done yet in other phases)
+-- TODO: implement flattening AnyOf the same way it's done for AllOf
-- DependAnyOf [DependAnyOf [something], rest] -> DependAnyOf $ something ++ rest
--- DependAllOf [DependAllOf [something], rest] -> DependAllOf $ something ++ rest
flatten :: Dependency -> Dependency
flatten d =
case d of
- (DependIfUse use dep) -> DependIfUse use (flatten dep)
- (DependAnyOf [dep]) -> flatten dep
- (DependAllOf [dep]) -> flatten dep
- (DependAnyOf deps) -> DependAnyOf $ map flatten deps
- (DependAllOf deps) -> DependAllOf $ map flatten deps
- (Atom _pn _dr _dattr) -> d
-
--- TODO: join atoms with different version constraints
+ DependIfUse use td fd -> DependIfUse use (go td) (go fd)
+ DependAnyOf [dep] -> go dep
+ DependAnyOf deps -> DependAnyOf $ map go deps
+
+ DependAllOf deps -> case L.partition is_dall_of (map go deps) of
+ ([], []) -> empty_dependency
+ ([], [dep]) -> dep
+ ([], ndall) -> DependAllOf ndall
+ (dall, ndall) -> go $ DependAllOf $ (concatMap undall dall) ++ ndall
+ Atom _pn _dr _dattr -> d
+ where go :: Dependency -> Dependency
+ go = flatten
+
+ is_dall_of :: Dependency -> Bool
+ is_dall_of d' =
+ case d' of
+ DependAllOf _deps -> True
+ _ -> False
+ undall :: Dependency -> [Dependency]
+ undall ~(DependAllOf ds) = ds
+
+-- joins atoms with different version boundaries
-- DependAllOf [ DRange ">=foo-1" Inf, Drange Zero "<foo-2" ] -> DRange ">=foo-1" "<foo-2"
combine_atoms :: Dependency -> Dependency
combine_atoms d =
case d of
- (DependIfUse use dep) -> DependIfUse use (combine_atoms dep)
- (DependAllOf deps) -> DependAllOf $ map combine_atoms $ find_intersections deps
- (DependAnyOf deps) -> DependAnyOf $ map combine_atoms $ find_concatenations deps
- (Atom _pn _dr _dattr) -> d
+ DependIfUse use td fd -> DependIfUse use (go td) (go fd)
+ DependAllOf deps -> DependAllOf $ map go $ find_atom_intersections deps
+ DependAnyOf deps -> DependAnyOf $ map go $ find_atom_concatenations deps
+ Atom _pn _dr _dattr -> d
+ where go = combine_atoms
-find_intersections :: [Dependency] -> [Dependency]
-find_intersections = map merge_depends . L.groupBy is_mergeable
+find_atom_intersections :: [Dependency] -> [Dependency]
+find_atom_intersections = map merge_depends . L.groupBy is_mergeable
where is_mergeable :: Dependency -> Dependency -> Bool
is_mergeable (Atom lpn _ldrange lattr) (Atom rpn _rdrange rattr) = (lpn, lattr) == (rpn, rattr)
is_mergeable _ _ = False
merge_depends :: [Dependency] -> Dependency
merge_depends [x] = x
- merge_depends xs = foldl1 merge_pair xs
+ merge_depends xs = L.foldl1' merge_pair xs
merge_pair :: Dependency -> Dependency -> Dependency
merge_pair (Atom lp ld la) (Atom rp rd ra)
@@ -97,73 +114,65 @@ find_intersections = map merge_depends . L.groupBy is_mergeable
merge_pair l r = error $ unwords ["merge_pair can't merge non-atoms:", show l, show r]
-- TODO
-find_concatenations :: [Dependency] -> [Dependency]
-find_concatenations = id
+find_atom_concatenations :: [Dependency] -> [Dependency]
+find_atom_concatenations = id
-- Eliminate use guarded redundancy:
-- a? ( foo )
-- a? ( bar )
-- gets translated to
-- a? ( foo bar )
-combine_use_guards :: Dependency -> Dependency
-combine_use_guards d =
- case d of
- (DependIfUse use dep) -> DependIfUse use (combine_use_guards dep)
- (DependAllOf deps) -> DependAllOf $ map combine_use_guards $ find_use_intersections deps
- (DependAnyOf deps) -> DependAnyOf $ map combine_use_guards $ find_use_concatenations deps
- (Atom _pn _dr _dattr) -> d
- where -- TODO
- find_use_concatenations :: [Dependency] -> [Dependency]
- find_use_concatenations = id
- find_use_intersections :: [Dependency] -> [Dependency]
- find_use_intersections = map merge_use_intersections . L.groupBy is_use_mergeable
- where
- is_use_mergeable :: Dependency -> Dependency -> Bool
- is_use_mergeable (DependIfUse lu _ld) (DependIfUse ru _rd)
- | lu == ru = True
- is_use_mergeable _ _ = False
- merge_use_intersections :: [Dependency] -> Dependency
- merge_use_intersections [x] = x
- merge_use_intersections ~(DependIfUse u dep : ds) = DependIfUse u $ DependAllOf (dep : [d' | (DependIfUse _u d') <- ds])
--- Eliminate use guarded redundancy:
-- a? ( foo bar )
-- !a? ( foo baz )
-- gets translated to
-- foo
-- a? ( bar )
-- !a? ( baz )
-combine_use_counterguards :: Dependency -> Dependency
-combine_use_counterguards d =
+
+combine_use_guards :: Dependency -> Dependency
+combine_use_guards d =
case d of
- (DependIfUse use dep) -> DependIfUse use (combine_use_counterguards dep)
- (DependAllOf deps) -> DependAllOf $ map combine_use_counterguards $ find_use_intersections deps
- (DependAnyOf deps) -> DependAnyOf $ map combine_use_counterguards $ find_use_concatenations deps
- (Atom _pn _dr _dattr) -> d
- where -- TODO
- find_use_concatenations :: [Dependency] -> [Dependency]
- find_use_concatenations = id
- find_use_intersections :: [Dependency] -> [Dependency]
- find_use_intersections = concatMap merge_use_intersections . L.groupBy is_counteruse_mergeable
- where
- is_counteruse_mergeable :: Dependency -> Dependency -> Bool
- is_counteruse_mergeable (DependIfUse (DUse (lb,lu)) _ld) (DependIfUse (DUse (rb, ru)) _rd)
- -- lookup 'a?' and '!a?'
- | lu == ru && lb == not rb = True
- is_counteruse_mergeable _ _ = False
- merge_use_intersections :: [Dependency] -> [Dependency]
- merge_use_intersections [(DependIfUse _lu ld), (DependIfUse _ru rd)]
- -- very simple special case,
- -- as we can't look through nested use guards
- | ld == rd = [ld]
- merge_use_intersections deps@[(DependIfUse _lu ld), (DependIfUse _ru rd)] =
- case common_ctx of
- [] -> deps
- _ -> [propagate_context $ DependAllOf $ common_ctx ++ deps ]
- where ld_ctx = lift_context' ld
- rd_ctx = lift_context' rd
- common_ctx = ld_ctx `L.intersect` rd_ctx
- merge_use_intersections x = x
+ DependIfUse use td fd -> pop_common $ DependIfUse use (go td) (go fd)
+ DependAllOf deps -> DependAllOf $ map go $ find_use_intersections deps
+ DependAnyOf deps -> DependAnyOf $ map go $ find_use_concatenations deps
+ Atom _pn _dr _dattr -> d
+ where go = combine_use_guards
+
+find_use_intersections :: [Dependency] -> [Dependency]
+find_use_intersections = map merge_use_intersections . L.groupBy is_use_mergeable
+ where
+ is_use_mergeable :: Dependency -> Dependency -> Bool
+ is_use_mergeable (DependIfUse lu _ltd _lfd) (DependIfUse ru _rtd _rfd)
+ | lu == ru = True
+ is_use_mergeable _ _ = False
+
+ merge_use_intersections :: [Dependency] -> Dependency
+ merge_use_intersections [x] = x
+ merge_use_intersections ds = pop_common $ DependIfUse u (DependAllOf tds) (DependAllOf fds)
+ where DependIfUse u _tf _fd = head ds
+ tfdeps ~(DependIfUse _u td fd) = (td, fd)
+ (tds, fds) = unzip $ map tfdeps ds
+
+pop_common :: Dependency -> Dependency
+-- depend
+-- a? ( x ) !a? ( x )
+-- gets translated to
+-- x
+pop_common (DependIfUse _u td fd)
+ | td == fd = fd
+pop_common d'@(DependIfUse _u td fd) =
+ case td_ctx `L.intersect` fd_ctx of
+ [] -> d'
+ -- TODO: force simplification right there
+ common_ctx -> DependAllOf $ propagate_context' common_ctx d' : common_ctx
+ where td_ctx = lift_context' td
+ fd_ctx = lift_context' fd
+pop_common x = x
+
+-- TODO
+find_use_concatenations :: [Dependency] -> [Dependency]
+find_use_concatenations = id
-- Eliminate top-down redundancy:
-- foo/bar
@@ -178,30 +187,50 @@ propagate_context = propagate_context' []
-- very simple model: pick all sibling-atom deps and add them to context
-- for downward proparation and remove from 'all_of' part
-- TODO: any-of part can benefit from it by removing unsatisfiable or satisfied alternative
--- TODO: remove use-guarded redundancy
--- a? ( x y z )
--- test? ( a? ( y z t ) )
--- can be reduced to
--- a? ( x y z )
--- test? ( a? ( t ) )
propagate_context' :: [Dependency] -> Dependency -> Dependency
propagate_context' ctx d =
case d of
- (DependIfUse use dep) -> DependIfUse use (go ctx dep)
- (DependAllOf deps) -> DependAllOf $ [ go ctx' dep
- | dep <- deps
- , let atom_deps = [ a
- | a@(Atom _pn _dp _dattr) <- deps
- , a /= dep ]
- , let ctx' = ctx ++ atom_deps
- ]
- (DependAnyOf deps) -> DependAnyOf $ map (go ctx) deps
- -- 'd' is already satisfied by 'ctx' constraint
- (Atom _pn _dr _dattr) -> case any (\ctx_e -> ctx_e `dep_is_case_of` d) ctx of
+ DependIfUse use td fd -> DependIfUse use (go (refine_context (True, use) ctx) td)
+ (go (refine_context (False, use) ctx) fd)
+ DependAllOf deps -> DependAllOf $ fromJust $ msum $
+ [ v
+ | (optimized_d, other_deps) <- slice_list deps
+ , let ctx' = ctx ++ other_deps
+ d' = go ctx' optimized_d
+ v = case d' /= optimized_d of
+ True -> Just (d':other_deps)
+ False -> Nothing -- haven't managed to optimize anything
+ ] ++ [Just deps] -- unmodified
+ DependAnyOf deps -> DependAnyOf $ map (go ctx) deps
+ Atom _pn _dr _dattr -> case any (dep_as_broad_as d) ctx of
True -> empty_dependency
False -> d
where go c = propagate_context' c
+refine_context :: (Bool, Use) -> [Dependency] -> [Dependency]
+refine_context use_cond = map (stabilize_pass flatten . refine_ctx_unit use_cond)
+ where refine_ctx_unit :: (Bool, Use) -> Dependency -> Dependency
+ refine_ctx_unit uc@(bu, u) d =
+ case d of
+ DependIfUse u' td fd
+ -> case u == u' of
+ False -> DependIfUse u' (refine_ctx_unit uc td)
+ (refine_ctx_unit uc fd)
+ True -> refine_ctx_unit uc $ if bu
+ then td
+ else fd
+ _ -> d
+
+-- generates all pairs of:
+-- (list_element, list_without_element)
+-- example:
+-- [1,2,3]
+-- yields
+-- [(1, [2,3]), (2,[1,3]), (3,[1,2])]
+slice_list :: [e] -> [(e, [e])]
+slice_list [] = []
+slice_list (e:es) = (e, es) : map (\(v, vs) -> (v, e : vs)) (slice_list es)
+
-- Eliminate bottom-up redundancy:
-- || ( ( foo/bar bar/baz )
-- ( foo/bar bar/quux ) )
@@ -215,47 +244,104 @@ propagate_context' ctx d =
-- foo/bar
-- || ( bar/baz
-- bar/quux )
-
+-- TODO: better add propagation in this exact plase to keep tree shrinking only
lift_context :: Dependency -> Dependency
lift_context d =
case d of
- (DependIfUse _use _dep) -> d
- (DependAllOf deps) -> DependAllOf $ deps ++ (new_ctx L.\\ deps)
+ DependIfUse _use _td _fd -> case L.delete d new_ctx of
+ [] -> d
+ new_ctx' -> propagate_context $ DependAllOf $ d : new_ctx'
+ DependAllOf deps -> case new_ctx L.\\ deps of
+ [] -> d
+ new_ctx' -> DependAllOf $ deps ++ new_ctx'
-- the lift itself
- (DependAnyOf _deps) -> case L.null new_ctx of
- True -> d -- nothing is shared downwards
- False -> propagate_context $ DependAllOf $ new_ctx ++ [d]
- (Atom _pn _dr _dattr) -> d
+ DependAnyOf _deps -> case L.delete d new_ctx of
+ [] -> d
+ new_ctx' -> propagate_context $ DependAllOf $ d : new_ctx'
+ Atom _pn _dr _dattr -> d
where new_ctx = lift_context' d
--- very simple model: pick all sibling-atom deps and add them to context
--- for upward proparation and intersect with 'all_of' parts
+-- lift everything that can be shared somewhere else
+-- propagate_context will then pick some bits from here
+-- and remove them deep inside.
+-- It's the most fragile and powerfull pass
lift_context' :: Dependency -> [Dependency]
lift_context' d =
case d of
- (DependIfUse _use _dep) -> []
- (DependAllOf deps) -> [dep | dep@(Atom _pn _dr _dattr) <- deps]
- (DependAnyOf deps) -> case map lift_context' deps of
- [] -> []
- ctxes -> foldl1 L.intersect ctxes
- (Atom _pn _dr _dattr) -> [d]
+ DependIfUse _use td fd -> d : extract_common_constraints (map lift_context' [td, fd])
+ DependAllOf deps -> L.nub $ concatMap lift_context' deps
+ DependAnyOf deps -> extract_common_constraints $ map lift_context' deps
+ Atom _pn _dr _dattr -> [d]
+
+-- it extracts common part of dependency comstraints.
+-- Some examples:
+-- 'a b c' and 'b c d' have common 'b c'
+-- 'u? ( a b )' and 'u? ( b c )' have common 'u? ( b )' part
+-- 'a? ( b? ( x y ) )' and !a? ( b? ( y z ) )' have common 'b? ( y )'
+extract_common_constraints :: [[Dependency]] -> [Dependency]
+extract_common_constraints [] = []
+extract_common_constraints dss@(ds:dst) = common_atoms ++ common_use_guards
+ where common_atoms :: [Dependency]
+ common_atoms = L.foldl1' L.intersect dss
+ common_use_guards :: [Dependency]
+ common_use_guards = [ DependIfUse u (DependAllOf tdi) (DependAllOf fdi)
+ | DependIfUse u td fd <- ds
+ , Just (tds, fds) <- [find_matching_use_deps dst u ([lift_context' td], [lift_context' fd])]
+ , let tdi = extract_common_constraints tds
+ fdi = extract_common_constraints fds
+ , not (null tdi && null fdi)
+ ]
+
+find_matching_use_deps :: [[Dependency]] -> Use -> ([[Dependency]], [[Dependency]]) -> Maybe ([[Dependency]], [[Dependency]])
+find_matching_use_deps dss u (tds, fds) =
+ case dss of
+ [] -> Just (tds, fds)
+ (ds:dst) -> case [ (tc, fc)
+ | DependIfUse u' td fd <- ds
+ , u' == u
+ , let tc = lift_context' td
+ fc = lift_context' fd
+ , not (null tc && null fc)
+ ] of
+ [] -> Nothing
+ pairs -> find_matching_use_deps dst u (map fst pairs ++ tds, map snd pairs ++ fds)
-- reorders depends to make them more attractive
-- for other normalization algorithms
--- TODO: add all logic from 'sortDeps' here
+-- and for final pretty-printer
sort_deps :: Dependency -> Dependency
sort_deps d =
case d of
- (DependIfUse lhs (DependIfUse rhs dep))
- | rhs < lhs -> DependIfUse rhs $ sort_deps $ DependIfUse lhs dep
- (DependIfUse use dep) -> DependIfUse use $ sort_deps dep
- (DependAnyOf deps) -> DependAnyOf $ map sort_deps deps
- (DependAllOf deps) -> DependAllOf $ map sort_deps deps
- (Atom _pn _dr _dattr) -> d
+ DependIfUse lu lt lf
+ | is_empty_dependency lf ->
+ case lt of
+ DependIfUse ru rt rf
+ -- b? ( a? ( d ) )
+ | ru < lu && is_empty_dependency rf -> mkUseDependency (True, ru) $ mkUseDependency (True, lu) (go rt)
+ -- b? ( !a? ( d ) )
+ | ru < lu && is_empty_dependency rt -> mkUseDependency (False, ru) $ mkUseDependency (True, lu) (go rf)
+ _ -> DependIfUse lu (go lt) (go lf)
+ | is_empty_dependency lt ->
+ case lf of
+ DependIfUse ru rt rf
+ -- !b? ( a? ( d ) )
+ | ru < lu && is_empty_dependency rf -> mkUseDependency (True, ru) $ mkUseDependency (False, lu) (go rt)
+ -- !b? ( !a? ( d ) )
+ | ru < lu && is_empty_dependency rt -> mkUseDependency (False, ru) $ mkUseDependency (False, lu) (go rf)
+ _ -> DependIfUse lu (go lt) (go lf)
+ DependIfUse use td fd -> DependIfUse use (go td) (go fd)
+ DependAnyOf deps -> DependAnyOf $ L.sort $ map go deps
+ DependAllOf deps -> DependAllOf $ L.sort $ map go deps
+ Atom _pn _dr _dattr -> d
+ where go = sort_deps
-- remove various types of redundancy
normalize_depend :: Dependency -> Dependency
-normalize_depend d = next_step next_d
+normalize_depend = normalize_depend' 50 -- arbitrary limit
+
+normalize_depend' :: Int -> Dependency -> Dependency
+normalize_depend' 0 d = trace "WARNING: Normalize_depend hung up. Optimization is incomplete." d
+normalize_depend' level d = next_step next_d
where next_d = normalization_step d
next_step | d == next_d = id
- | otherwise = normalize_depend
+ | otherwise = normalize_depend' (level - 1)
diff --git a/Portage/Dependency/Print.hs b/Portage/Dependency/Print.hs
index 189a1c8..d68aa46 100644
--- a/Portage/Dependency/Print.hs
+++ b/Portage/Dependency/Print.hs
@@ -1,7 +1,7 @@
module Portage.Dependency.Print
(
dep2str
- , dep2str_denorm -- for debugging
+ , dep2str_noindent
) where
import Portage.Version
@@ -9,11 +9,10 @@ import Portage.Use
import Portage.PackageId
-import Distribution.Text ( Text(..) )
+import qualified Distribution.Text as DT
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ( (<>), vcat, nest, render )
-import Portage.Dependency.Normalize
import Portage.Dependency.Types
dispSlot :: SlotDepend -> Disp.Doc
@@ -22,28 +21,23 @@ dispSlot AnyBuildTimeSlot = Disp.text ":="
dispSlot (GivenSlot slot) = Disp.text (':' : slot)
dispLBound :: PackageName -> LBound -> Disp.Doc
-dispLBound pn (StrictLB v) = Disp.char '>' <> disp pn <-> disp v
-dispLBound pn (NonstrictLB v) = Disp.text ">=" <> disp pn <-> disp v
+dispLBound pn (StrictLB v) = Disp.char '>' <> DT.disp pn <-> DT.disp v
+dispLBound pn (NonstrictLB v) = Disp.text ">=" <> DT.disp pn <-> DT.disp v
dispLBound _pn ZeroB = error "unhandled 'dispLBound ZeroB'"
dispUBound :: PackageName -> UBound -> Disp.Doc
-dispUBound pn (StrictUB v) = Disp.char '<' <> disp pn <-> disp v
-dispUBound pn (NonstrictUB v) = Disp.text "<=" <> disp pn <-> disp v
+dispUBound pn (StrictUB v) = Disp.char '<' <> DT.disp pn <-> DT.disp v
+dispUBound pn (NonstrictUB v) = Disp.text "<=" <> DT.disp pn <-> DT.disp v
dispUBound _pn InfinityB = error "unhandled 'dispUBound Infinity'"
dispDAttr :: DAttr -> Disp.Doc
dispDAttr (DAttr s u) = dispSlot s <> dispUses u
-dispDUse :: DUse -> Disp.Doc
-dispDUse (DUse (is_enabled, name)) = prefix is_enabled <> Disp.text name <> Disp.char '?'
- where prefix True = Disp.empty
- prefix False = Disp.char '!'
-
dep2str :: Int -> Dependency -> String
-dep2str start_indent = render . nest start_indent . showDepend . normalize_depend
+dep2str start_indent = render . nest start_indent . showDepend
-dep2str_denorm :: Dependency -> String
-dep2str_denorm = render . showDepend
+dep2str_noindent :: Dependency -> String
+dep2str_noindent = render . showDepend
(<->) :: Disp.Doc -> Disp.Doc -> Disp.Doc
a <-> b = a <> Disp.char '-' <> b
@@ -61,7 +55,7 @@ showDepend :: Dependency -> Disp.Doc
showDepend (Atom pn range dattr)
= case range of
-- any version
- DRange ZeroB InfinityB -> disp pn <> dispDAttr dattr
+ DRange ZeroB InfinityB -> DT.disp pn <> dispDAttr dattr
DRange ZeroB ub -> dispUBound pn ub <> dispDAttr dattr
DRange lb InfinityB -> dispLBound pn lb <> dispDAttr dattr
-- TODO: handle >=foo-0 special case
@@ -69,9 +63,15 @@ showDepend (Atom pn range dattr)
DRange lb ub -> showDepend (Atom pn (DRange lb InfinityB) dattr)
<> Disp.char ' '
<> showDepend (Atom pn (DRange ZeroB ub) dattr)
- DExact v -> Disp.char '~' <> disp pn <-> disp v { versionRevision = 0 } <> dispDAttr dattr
-
-showDepend (DependIfUse u dep) = dispDUse u <> sp <> sparens (showDepend dep)
+ DExact v -> Disp.char '~' <> DT.disp pn <-> DT.disp v { versionRevision = 0 } <> dispDAttr dattr
+
+showDepend (DependIfUse u td fd) = valign $ vcat [td_doc, fd_doc]
+ where td_doc
+ | is_empty_dependency td = Disp.empty
+ | otherwise = DT.disp u <> Disp.char '?' <> sp <> sparens (showDepend td)
+ fd_doc
+ | is_empty_dependency fd = Disp.empty
+ | otherwise = Disp.char '!' <> DT.disp u <> Disp.char '?' <> sp <> sparens (showDepend fd)
showDepend (DependAnyOf deps) = Disp.text "||" <> sp <> sparens (vcat $ map showDependInAnyOf deps)
showDepend (DependAllOf deps) = valign $ vcat $ map showDepend deps
diff --git a/Portage/Dependency/Types.hs b/Portage/Dependency/Types.hs
index 4ac1b8b..a5c7c23 100644
--- a/Portage/Dependency/Types.hs
+++ b/Portage/Dependency/Types.hs
@@ -5,9 +5,9 @@ module Portage.Dependency.Types
, UBound(..)
, DRange(..)
, DAttr(..)
- , DUse(..)
, Dependency(..)
- , dep_is_case_of
+ , dep_as_broad_as
+ , is_empty_dependency
) where
import Portage.PackageId
@@ -16,7 +16,7 @@ import Portage.Use
data SlotDepend = AnySlot -- nothing special
| AnyBuildTimeSlot -- ':='
| GivenSlot String -- ':slotno'
- deriving (Eq, Show)
+ deriving (Eq, Show, Ord)
data LBound = StrictLB Version
| NonstrictLB Version
@@ -29,9 +29,12 @@ instance Ord LBound where
compare _ ZeroB = GT
compare (StrictLB lv) (StrictLB rv) = compare lv rv
compare (NonstrictLB lv) (NonstrictLB rv) = compare lv rv
- compare l r = error $ unlines ["i am too lazy to implement LBound: compare"
- , show l
- , show r]
+ compare (StrictLB lv) (NonstrictLB rv) = case compare lv rv of
+ EQ -> GT
+ r -> r
+ compare (NonstrictLB lv) (StrictLB rv) = case compare lv rv of
+ EQ -> LT
+ r -> r
data UBound = StrictUB Version -- <
| NonstrictUB Version -- <=
@@ -42,55 +45,58 @@ instance Ord UBound where
compare InfinityB InfinityB = EQ
compare InfinityB _ = GT
compare _ InfinityB = LT
- compare (NonstrictUB lv) (NonstrictUB rv) = compare lv rv
compare (StrictUB lv) (StrictUB rv) = compare lv rv
- compare l r = error $ unlines ["i am too lazy to implement UBound: compare"
- , show l
- , show r]
+ compare (NonstrictUB lv) (NonstrictUB rv) = compare lv rv
+ compare (StrictUB lv) (NonstrictUB rv) = case compare lv rv of
+ EQ -> LT
+ r -> r
+ compare (NonstrictUB lv) (StrictUB rv) = case compare lv rv of
+ EQ -> GT
+ r -> r
data DRange = DRange LBound UBound
| DExact Version
- deriving (Eq, Show)
+ deriving (Eq, Show, Ord)
--- True if 'left' "interval" is a nonstrict subset of 'right' "interval"
-range_is_case_of :: DRange -> DRange -> Bool
-range_is_case_of (DRange llow lup) (DRange rlow rup)
- | llow >= rlow && lup <= rup = True
-range_is_case_of _ _ = False
+-- True if 'left' "interval" covers at least as much as the 'right' "interval"
+range_as_broad_as :: DRange -> DRange -> Bool
+range_as_broad_as (DRange llow lup) (DRange rlow rup)
+ | llow <= rlow && lup >= rup = True
+range_as_broad_as _ _ = False
data DAttr = DAttr SlotDepend [UseFlag]
- deriving (Eq, Show)
-
--- Simplified version of 'UseFlag'
--- used as a guarding depend:
--- foo? ( ... )
--- !foo? ( ... )
-data DUse = DUse (Bool, Use)
- deriving (Eq, Show)
-
--- sort order:
--- a? < b?
--- a? < !a?
--- but 'test?' is special
-instance Ord DUse where
- compare (DUse (lb, lname)) (DUse (rb, rname)) =
- case (lname, rname, compare lname rname) of
- (_, _, EQ) -> compare rb lb
- ("test", _, _) -> LT
- (_, "test", _) -> GT
- (_, _, v) -> v
+ deriving (Eq, Show, Ord)
data Dependency = Atom PackageName DRange DAttr
- | DependIfUse DUse Dependency
+ | DependIfUse Use Dependency Dependency -- u? ( td ) !u? ( fd )
| DependAnyOf [Dependency]
| DependAllOf [Dependency]
- deriving (Eq, Show)
+ deriving (Eq, Show, Ord)
-dep_is_case_of :: Dependency -> Dependency -> Bool
-dep_is_case_of l r
+-- returns 'True' if left constraint is the same (or looser) than right
+dep_as_broad_as :: Dependency -> Dependency -> Bool
+dep_as_broad_as l r
-- very broad (not only on atoms) special case
| l == r = True
--- only on atoms
-dep_is_case_of (Atom lpn lr lda) (Atom rpn rr rda)
- | lpn == rpn && lda == rda = lr `range_is_case_of` rr
-dep_is_case_of _ _ = False
+-- atoms
+dep_as_broad_as (Atom lpn lr lda) (Atom rpn rr rda)
+ | lpn == rpn && lda == rda = lr `range_as_broad_as` rr
+-- AllOf (very common case in context propagation)
+dep_as_broad_as d (DependAllOf deps)
+ | any (dep_as_broad_as d) deps = True
+dep_as_broad_as _ _ = False
+
+-- TODO: remove it and switch to 'SatisfiedDepend' instead
+is_empty_dependency :: Dependency -> Bool
+is_empty_dependency d =
+ case d of
+ DependIfUse _use td fd
+ -> is_empty_dependency td && is_empty_dependency fd
+ DependAnyOf []
+ -> True -- 'any (const True) [] == False' and we don't want it
+ DependAnyOf deps
+ -> any is_empty_dependency deps
+ DependAllOf deps
+ -> all is_empty_dependency deps
+ Atom _pn _dr _dattr
+ -> False
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
index cba43e5..ce85865 100644
--- a/Portage/EBuild.hs
+++ b/Portage/EBuild.hs
@@ -6,6 +6,7 @@ module Portage.EBuild
) where
import Portage.Dependency
+import qualified Portage.Dependency.Normalize as PN
import Data.String.Utils
import qualified Data.Time.Clock as TC
@@ -176,7 +177,7 @@ tabify = unlines . map tabify_line . lines
dep_str :: String -> [String] -> [Dependency] -> DString
dep_str var extra deps = ss var. sc '='. quote' (ss $ drop_leadings $ unlines extra ++ deps_s). nl
where indent = 1 * tab_size
- deps_s = tabify (dep2str indent (DependAllOf deps))
+ deps_s = tabify (dep2str indent $ PN.normalize_depend $ DependAllOf deps)
drop_leadings = dropWhile (== '\t')
quote :: String -> DString
diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs
index aee1dfc..104785d 100644
--- a/Portage/GHCCore.hs
+++ b/Portage/GHCCore.hs
@@ -1,10 +1,8 @@
-- Guess GHC version from packages depended upon.
module Portage.GHCCore
- ( coreLibs
- , minimumGHCVersionToBuildPackage
+ ( minimumGHCVersionToBuildPackage
, cabalFromGHC
- , defaultGHC
, finalizePackageDescription
, platform
, dependencySatisfiable
@@ -28,11 +26,12 @@ import Data.Version
import Debug.Trace
-defaultGHC :: (CompilerId, [PackageName])
-defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)
-
+-- ghcs tried in specified order.
+-- It means that first ghc in this list is a minmum default.
ghcs :: [(CompilerId, PackageIndex)]
-ghcs = [ghc6104, ghc6121, ghc6122, ghc6123, ghc704, ghc741, ghc742, ghc761, ghc762]
+ghcs = modern_ghcs ++ ancient_ghcs
+ where modern_ghcs = [ghc741, ghc742, ghc761, ghc762]
+ ancient_ghcs = [ghc6104, ghc6121, ghc6122, ghc6123, ghc704]
cabalFromGHC :: [Int] -> Maybe Version
cabalFromGHC ver = lookup ver table
@@ -77,10 +76,11 @@ dependencySatisfiable pindex dep@(Dependency pn _rang)
packageBuildableWithGHCVersion
:: GenericPackageDescription
+ -> FlagAssignment
-> (CompilerId, PackageIndex)
-> Either [Dependency] (PackageDescription, FlagAssignment)
-packageBuildableWithGHCVersion pkg (compiler, pkgIndex) = trace_failure $
- finalizePackageDescription [] (dependencySatisfiable pkgIndex) platform compiler [] pkg
+packageBuildableWithGHCVersion pkg user_specified_fas (compiler, pkgIndex) = trace_failure $
+ finalizePackageDescription user_specified_fas (dependencySatisfiable pkgIndex) platform compiler [] pkg
where trace_failure v = case v of
(Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler
, "as", show_deps deps
@@ -96,11 +96,11 @@ packageBuildableWithGHCVersion pkg (compiler, pkgIndex) = trace_failure $
-- | Given a 'GenericPackageDescription' it returns the miminum GHC version
-- to build a package, and a list of core packages to that GHC version.
-minimumGHCVersionToBuildPackage :: GenericPackageDescription -> Maybe (CompilerId, [PackageName], PackageDescription, FlagAssignment, PackageIndex)
-minimumGHCVersionToBuildPackage gpd =
+minimumGHCVersionToBuildPackage :: GenericPackageDescription -> FlagAssignment -> Maybe (CompilerId, [PackageName], PackageDescription, FlagAssignment, PackageIndex)
+minimumGHCVersionToBuildPackage gpd user_specified_fas =
listToMaybe [ (cid, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix)
| g@(cid, pix) <- ghcs
- , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd g)]
+ , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd user_specified_fas g)]
mkIndex :: [PackageIdentifier] -> PackageIndex
mkIndex pids = fromList
@@ -392,34 +392,3 @@ ghc6104_pkgs =
p :: String -> [Int] -> PackageIdentifier
p pn vs = PackageIdentifier (PackageName pn) (Version vs [])
-
-coreLibs :: [PackageName]
-coreLibs = map PackageName
- ["array"
- ,"base"
- ,"bytestring" -- intentionally no ebuild. use ghc's version
- -- to avoid dreaded 'diamond dependency' problem
- ,"containers"
- ,"directory"
- --,"editline"
- ,"filepath" -- intentionally no ebuild. use ghc's version
- ,"ghc"
- ,"ghc-prim"
- ,"haskell98"
- ,"hpc" --has ebuild, but only in the overlay
- ,"integer" -- up to ghc-6.10
- ,"integer-gmp" -- ghc-6.12+
- ,"old-locale"
- ,"old-time"
- ,"packedstring"
- ,"pretty"
- ,"process"
- -- ,"random" -- not a core package since ghc-7.2
- ,"rts"
- -- ,"syb" -- was splitted off from ghc again
- ,"template-haskell"
- ,"time" -- ghc-6.12+. startig from ghc-7.6.1 it is very
- -- unsafe to upgrade as most others (like directory)
- -- depend on it
- ,"unix" -- unsafe to upgrade
- ]
diff --git a/Portage/Use.hs b/Portage/Use.hs
index dcab0e0..e193ff6 100644
--- a/Portage/Use.hs
+++ b/Portage/Use.hs
@@ -1,7 +1,7 @@
module Portage.Use (
-- * main structures
UseFlag(..),
- Use,
+ Use(..),
dispUses,
-- * helpers
mkUse,
@@ -11,7 +11,7 @@ module Portage.Use (
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>))
-import Distribution.Text ( Text(..) )
+import qualified Distribution.Text as DT
-- | Use variable modificator
data UseFlag = UseFlag Use -- ^ no modificator
@@ -21,16 +21,6 @@ data UseFlag = UseFlag Use -- ^ no modificator
| N UseFlag -- ^ - modificator
deriving (Eq,Show,Ord,Read)
-
-{-
-instance IsString UseFlag where
- fromString ('!':str) = X (fromString str)
- fromString ('-':str) = N (fromString str)
- fromString str = case last str of
- '?' -> Q (fromString (init str))
- '=' -> E (fromString (init str))
- s -> UseFlag s
--}
mkUse :: Use -> UseFlag
mkUse = UseFlag
@@ -40,20 +30,31 @@ mkNotUse = N . UseFlag
mkQUse :: Use -> UseFlag
mkQUse = Q . UseFlag
-
-instance Text UseFlag where
+instance DT.Text UseFlag where
disp = showModificator
+ parse = error "instance DT.Text UseFlag: not implemented"
showModificator :: UseFlag -> Disp.Doc
-showModificator (UseFlag u) = Disp.text u
-showModificator (X u) = Disp.char '!' <> disp u
-showModificator (Q u) = disp u <> Disp.char '?'
-showModificator (E u) = disp u <> Disp.char '='
-showModificator (N u) = Disp.char '-' <> disp u
+showModificator (UseFlag u) = DT.disp u
+showModificator (X u) = Disp.char '!' <> DT.disp u
+showModificator (Q u) = DT.disp u <> Disp.char '?'
+showModificator (E u) = DT.disp u <> Disp.char '='
+showModificator (N u) = Disp.char '-' <> DT.disp u
dispUses :: [UseFlag] -> Disp.Doc
dispUses [] = Disp.empty
-dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ map disp us
+dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ map DT.disp us
+
+newtype Use = Use String
+ deriving (Eq, Read, Show)
-type Use = String
+instance Ord Use where
+ compare (Use a) (Use b) = case (a,b) of
+ ("test", "test") -> EQ
+ ("test", _) -> LT
+ (_, "test") -> GT
+ (_, _) -> a `compare` b
+instance DT.Text Use where
+ disp (Use u) = Disp.text u
+ parse = error "instance DT.Text Use: not implemented"
diff --git a/hackport.cabal b/hackport.cabal
index 5f0b5df..7952de9 100644
--- a/hackport.cabal
+++ b/hackport.cabal
@@ -1,5 +1,5 @@
Name: hackport
-Version: 0.3.6
+Version: 0.4
License: GPL
License-file: LICENSE
Author: Henning G√ľnther, Duncan Coutts, Lennart Kolmodin
@@ -68,7 +68,6 @@ Executable hackport
other-modules:
AnsiColor
- BlingBling
Cabal2Ebuild
CacheFile
Diff
diff --git a/mk_release_tarball.bash b/mk_release_tarball.bash
index dff59d4..7fba135 100755
--- a/mk_release_tarball.bash
+++ b/mk_release_tarball.bash
@@ -19,9 +19,9 @@ tarball_name="${srcdir}/${P}.tar.gz"
git submodule update --init
# drop redundant bits
- rm -r -- .git cabal/.git
+ rm -rf -- .git cabal/.git
# cabal is not able to unpack long tar names
- rm -r -- cabal/Cabal/tests
+ rm -rf -- cabal/Cabal/tests
)
tar -czf "${tarball_name}" "${P}"/
)
diff --git a/tests/normalize_deps.hs b/tests/normalize_deps.hs
index a2be7da..c1d7af2 100644
--- a/tests/normalize_deps.hs
+++ b/tests/normalize_deps.hs
@@ -4,6 +4,7 @@ import Data.List
import Test.HUnit
import qualified Portage.Dependency as P
+import qualified Portage.Dependency.Normalize as PN
import qualified Portage.PackageId as P
import qualified Portage.Use as P
import qualified RunTests as RT
@@ -44,11 +45,11 @@ d_p pn = P.Atom (P.mkPackageName "c" pn)
(P.DRange P.ZeroB P.InfinityB)
def_attr
-d_use :: P.Use -> P.Dependency -> P.Dependency
-d_use u d = P.DependIfUse (P.DUse (True, u)) d
+d_use :: String -> P.Dependency -> P.Dependency
+d_use u d = P.mkUseDependency (True, P.Use u) d
-d_nuse :: P.Use -> P.Dependency -> P.Dependency
-d_nuse u d = P.DependIfUse (P.DUse (False, u)) d
+d_nuse :: String -> P.Dependency -> P.Dependency
+d_nuse u d = P.mkUseDependency (False, P.Use u) d
test_normalize_in_use_and_top :: Test
test_normalize_in_use_and_top = TestCase $ do
@@ -76,8 +77,8 @@ test_normalize_in_use_and_top = TestCase $ do
]
]
, [ ">=dev-haskell/mtl-1.0"
- , "|| ( >=dev-haskell/quickcheck-1.2"
- , " >=dev-haskell/parsec-3.1 )"
+ , "|| ( >=dev-haskell/parsec-3.1"
+ , " >=dev-haskell/quickcheck-1.2 )"
]
)
, ( d_all [ d_use "foo" $ d_use "bar" $ d_ge pnm [1,0]
@@ -123,27 +124,71 @@ test_normalize_in_use_and_top = TestCase $ do
,
[ ">=dev-haskell/mtl-2.0" ]
)
- {- TODO: this one is hardest to implement,
- but also most interesting simplification
- due to our dependency expansion when resolving.
+ , -- propagate use guarded depend into deeply nested one
+ ( d_all [ d_use "a" $ d_all $ map d_p [ "x" ]
+ , d_use "test" $ d_use "a" $ d_all $ map d_p [ "x", "t" ]
+ ]
+ , [ "test? ( a? ( c/t ) )"
+ , "a? ( c/x )"
+ ]
+ )
, -- lift nested use context for complementary depends
- -- a? b? ( x y ) !a? b? ( x )
- -- leads to
- -- a? ( y ) b? ( x )
+ -- a? ( b? ( y ) ) b? ( x )
( d_all [ d_use "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]
, d_nuse "a" $ d_use "b" $ d_p "x"
]
- , [ "c/x"
- , "c/y"
- , "a? ( c/y )"
+ , [ "a? ( b? ( c/y ) )"
, "b? ( c/x )"
]
)
- -}
+ , -- more advanced lift of complementary deps
+ -- a? ( b? ( x y ) )
+ -- !a? ( b? ( y z ) )
+ ( d_all [ d_use "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]
+ , d_nuse "a" $ d_use "b" $ d_all $ map d_p [ "y", "z" ]
+ ]
+ , [ "a? ( b? ( c/x ) )"
+ , "!a? ( b? ( c/z ) )"
+ , "b? ( c/y )"
+ ]
+ )
+ , -- completely expanded set of USEs
+ -- a? ( b? ( c? ( x y z ) )
+ -- a? ( b? ( !c? ( x y ) )
+ -- a? ( !b? ( c? ( x z ) )
+ -- a? ( !b? ( !c? ( x ) )
+ --
+ -- !a? ( b? ( c? ( y z ) )
+ -- !a? ( b? ( !c? ( y ) )
+ -- !a? ( !b? ( c? ( z ) )
+ -- !a? ( !b? ( !c? ( ) )
+ ( d_all [ d_use "a" $ d_use "b" $ d_use "c" $ d_all $ map d_p [ "x", "y", "z" ]
+ , d_use "a" $ d_use "b" $ d_nuse "c" $ d_all $ map d_p [ "x", "y" ]
+ , d_use "a" $ d_nuse "b" $ d_use "c" $ d_all $ map d_p [ "x", "z" ]
+ , d_use "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ "x" ]
+ , d_nuse "a" $ d_use "b" $ d_use "c" $ d_all $ map d_p [ "y", "z" ]
+ , d_nuse "a" $ d_use "b" $ d_nuse "c" $ d_all $ map d_p [ "y" ]
+ , d_nuse "a" $ d_nuse "b" $ d_use "c" $ d_all $ map d_p [ "z" ]
+ , d_nuse "a" $ d_nuse "b" $ d_nuse "c" $ d_all $ map d_p [ ]
+ ]
+ , [ "a? ( c/x )"
+ , "b? ( c/y )"
+ , "c? ( c/z )"
+ ]
+ )
+ , -- pop simple common subdepend
+ -- a? ( b? ( d ) )
+ -- !a? ( b? ( d ) )
+ ( d_all [ d_use "a" $ d_use "b" $ d_p "d"
+ , d_nuse "a" $ d_use "b" $ d_p "d"
+ ]
+ , [ "b? ( c/d )"
+ ]
+ )
]
forM_ deps $ \(d, expected) ->
- let actual = P.dep2str 0 d
- in assertEqual ("expecting empty result for " ++ show d)
+ let actual = P.dep2str 0 $ PN.normalize_depend d
+ in assertEqual ("expecting matching result for " ++ show d)
(intercalate "\n" expected)
actual
diff --git a/tests/print_deps.hs b/tests/print_deps.hs
index 1cba2c6..ab3894d 100644
--- a/tests/print_deps.hs
+++ b/tests/print_deps.hs
@@ -4,7 +4,9 @@ import Data.List
import Test.HUnit
import qualified Portage.Dependency as P
+import qualified Portage.Dependency.Normalize as PN
import qualified Portage.PackageId as P
+import qualified Portage.Use as P
import qualified RunTests as RT
tests :: Test
@@ -18,7 +20,7 @@ test_print_empty = TestCase $ do
let expect_empty = ""
d_all = P.DependAllOf
d_any = P.DependAnyOf
- d_use u dep = P.DependIfUse (P.DUse (True, u)) dep
+ d_use u dep = P.mkUseDependency (True, P.Use u) dep
deps = [ d_all []
, d_any []
, d_use "f" (d_all [])
@@ -39,7 +41,7 @@ test_print_empty = TestCase $ do
]
]
forM_ deps $ \d ->
- let actual_result = P.dep2str 0 d
+ let actual_result = P.dep2str 0 $ PN.normalize_depend d
in assertEqual ("expecting empty result for " ++ show d)
expect_empty
actual_result
@@ -81,7 +83,7 @@ test_print_mixed = TestCase $ do
)
]
forM_ deps $ \(d, expected) ->
- let actual = P.dep2str 0 d
+ let actual = P.dep2str 0 $ PN.normalize_depend d
in assertEqual ("expecting empty result for " ++ show d)
(intercalate "\n" expected)
actual
@@ -129,7 +131,7 @@ test_print_denorm = TestCase $ do
)
]
forM_ deps $ \(d, expected) ->
- let actual = P.dep2str_denorm d
+ let actual = P.dep2str_noindent d
in assertEqual ("expecting empty result for " ++ show d)
(intercalate "\n" expected)
actual