diff --git a/BlingBling.hs b/BlingBling.hs deleted file mode 100644 --- 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 --- a/Cabal2Ebuild.hs +++ b/Cabal2Ebuild.hs @@ -29,8 +29,7 @@ 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 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 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 --- a/Merge.hs +++ b/Merge.hs @@ -12,6 +12,7 @@ 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 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 @@ 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 @@ 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 @@ , " $ 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 @@ | (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 @@ [] 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 @@ , 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 @@ 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 @@ 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] + in [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) - ) - ([],[],[]) 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 @@ 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 @@ 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 --- a/Merge/Dependencies.hs +++ b/Merge/Dependencies.hs @@ -72,6 +72,7 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ | 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 @@ 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 @@ 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 @@ -- | 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 @@ --------------------------------------------------------------- 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 @@ , ("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 @@ , ("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 --- 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 @@ 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 --- 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 @@ ) 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.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 @@ 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 @@ 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 = 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 --- a/Portage/Dependency/Builder.hs +++ b/Portage/Dependency/Builder.hs @@ -4,11 +4,13 @@ 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 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 --- a/Portage/Dependency/Normalize.hs +++ b/Portage/Dependency/Normalize.hs @@ -3,37 +3,38 @@ 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 @@ -- 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 + DependIfUse use td fd -> DependIfUse use (go td) (go fd) + DependAnyOf [dep] -> go dep + DependAnyOf deps -> DependAnyOf $ map go deps --- TODO: join atoms with different version constraints + 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 " DRange ">=foo-1" " 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,74 +114,66 @@ 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 -- u? ( foo/bar @@ -178,30 +187,50 @@ -- 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 @@ -- 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 --- 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.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 (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 (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 @@ 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 + DExact v -> Disp.char '~' <> DT.disp pn <-> DT.disp v { versionRevision = 0 } <> dispDAttr dattr -showDepend (DependIfUse u dep) = dispDUse u <> sp <> sparens (showDepend dep) +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 --- a/Portage/Dependency/Types.hs +++ b/Portage/Dependency/Types.hs @@ -5,9 +5,9 @@ , UBound(..) , DRange(..) , DAttr(..) - , DUse(..) , Dependency(..) - , dep_is_case_of + , dep_as_broad_as + , is_empty_dependency ) where import Portage.PackageId @@ -16,7 +16,7 @@ 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 @@ 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 @@ 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 --- a/Portage/EBuild.hs +++ b/Portage/EBuild.hs @@ -6,6 +6,7 @@ ) 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 @@ 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 --- 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 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 @@ 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 @@ -- | 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 @@ 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 --- 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 @@ 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 @@ | 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 @@ 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 -type Use = String +newtype Use = Use String + deriving (Eq, Read, Show) +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 --- 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 @@ other-modules: AnsiColor - BlingBling Cabal2Ebuild CacheFile Diff diff --git a/mk_release_tarball.bash b/mk_release_tarball.bash --- a/mk_release_tarball.bash +++ b/mk_release_tarball.bash @@ -19,9 +19,9 @@ 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 --- a/tests/normalize_deps.hs +++ b/tests/normalize_deps.hs @@ -4,6 +4,7 @@ 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 @@ (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 @@ ] ] , [ ">=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 @@ , [ ">=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 --- a/tests/print_deps.hs +++ b/tests/print_deps.hs @@ -4,7 +4,9 @@ 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 @@ 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 @@ ] ] 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 @@ ) ] 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 @@ ) ] 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