hackport 0.4.2 → 0.4.3
raw patch · 12 files changed
+205/−69 lines, 12 files
Files
- AnsiColor.hs +0/−1
- Cabal2Ebuild.hs +0/−5
- Merge.hs +41/−11
- Merge/Dependencies.hs +6/−1
- Portage/Dependency/Normalize.hs +88/−41
- Portage/Dependency/Types.hs +1/−1
- Portage/EBuild.hs +11/−3
- Portage/Metadata.hs +0/−3
- Progress.hs +0/−1
- Status.hs +3/−1
- hackport.cabal +1/−1
- tests/normalize_deps.hs +54/−0
AnsiColor.hs view
@@ -1,5 +1,4 @@ {-|- Maintainer : Andres Loeh <kosmikus@gentoo.org> Stability : provisional Portability : haskell98
Cabal2Ebuild.hs view
@@ -16,11 +16,6 @@ -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. ----- |--- Maintainer : haskell@gentoo.org------ cabal2ebuild - a program for generating a Gentoo ebuild from a .cabal file--- module Cabal2Ebuild (cabal2ebuild ,convertDependencies
Merge.hs view
@@ -277,26 +277,54 @@ active_flags = all_flags L.\\ common_flags active_flag_descs = filter (\x -> Cabal.flagName x `elem` active_flags) cabal_flag_descs irresolvable_flag_assignments = all_possible_flag_assignments L.\\ successfully_resolved_flag_assignments+ -- flags, not guarding any dependency variation, like:+ -- if flag(foo)+ -- ghc-options: -O2+ (irrelevant_flags, deps1') = L.foldl' drop_irrelevant ([], deps1) active_flags+ where drop_irrelevant :: ([Cabal.FlagName], [(Cabal.FlagAssignment, Merge.EDep)]) -> Cabal.FlagName -> ([Cabal.FlagName], [(Cabal.FlagAssignment, Merge.EDep)])+ drop_irrelevant (ifs, ds) f =+ case fenabled_ds' == fdisabled_ds' of+ True -> (f:ifs, fenabled_ds')+ False -> ( ifs, ds)+ where (fenabled_ds', fdisabled_ds') = ( L.sort $ map drop_f fenabled_ds+ , L.sort $ map drop_f fdisabled_ds+ )+ drop_f :: (Cabal.FlagAssignment, Merge.EDep) -> (Cabal.FlagAssignment, Merge.EDep)+ drop_f (fas, d) = (filter ((f /=) . fst) fas, d)+ (fenabled_ds, fdisabled_ds) = L.partition is_fe ds+ is_fe :: (Cabal.FlagAssignment, Merge.EDep) -> Bool+ is_fe (fas, _d) =+ case lookup f fas of+ Just v -> v+ -- should not happen+ Nothing -> error $ unwords [ "ERROR: drop_irrelevant: searched for missing flag"+ , show f+ , "in assignment"+ , show fas+ ]+ -- and finally prettify all deps: leave_only_dynamic_fa :: Cabal.FlagAssignment -> Cabal.FlagAssignment- leave_only_dynamic_fa fa = fa L.\\ common_fa+ leave_only_dynamic_fa fa = filter (\(fn, _) -> all (fn /=) irrelevant_flags) $ fa L.\\ common_fa + -- build roughly balanced complete dependency tree instead of skewed one+ bimerge :: [Merge.EDep] -> Merge.EDep+ bimerge deps = case go deps of+ [] -> mempty+ [r] -> r+ _ -> error "bimerge: something bad happened"+ where go deps' =+ case deps' of+ (d1:d2:ds) -> go (mappend d1 d2 : go ds)+ _ -> deps'+ tdeps :: Merge.EDep- (tdeps, _) = L.foldl' (\(a, c) v -> let r = a `mappend` v- in if c > (1024 :: Int)- then (trace ("RUN NORM:" ++ show (length (show r))) $- normalize_ed r, 0)- else ( r, c + 1)- ) (mempty, 0) $ map set_fa_to_ed deps1+ tdeps = bimerge $ map set_fa_to_ed deps1' set_fa_to_ed :: (Cabal.FlagAssignment, Merge.EDep) -> Merge.EDep set_fa_to_ed (fa, ed) = ed { Merge.rdep = liftFlags (leave_only_dynamic_fa fa) $ Merge.rdep ed , Merge.dep = liftFlags (leave_only_dynamic_fa fa) $ Merge.dep ed }- normalize_ed :: Merge.EDep -> Merge.EDep- normalize_ed ed = ed { Merge.rdep = PN.normalize_depend $ Merge.rdep ed- , Merge.dep = PN.normalize_depend $ Merge.dep ed- } liftFlags :: Cabal.FlagAssignment -> Portage.Dependency -> Portage.Dependency liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . unFlagName $ y) . x)@@ -314,6 +342,8 @@ notice verbosity $ "Skipped depends: " ++ show (map display skipped_deps) notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments) notice verbosity $ "Dropped flags: " ++ show (map (unFlagName.fst) common_fa)+ notice verbosity $ "Active flags: " ++ show (map unFlagName active_flags)+ notice verbosity $ "Irrelevant flags: " ++ show (map unFlagName irrelevant_flags) -- mapM_ print tdeps forM_ ghc_packages $
Merge/Dependencies.hs view
@@ -90,7 +90,7 @@ dep :: Portage.Dependency, dep_e :: S.Set String }- deriving (Show, Eq)+ deriving (Show, Eq, Ord) instance Monoid EDep where mempty = EDep@@ -336,6 +336,9 @@ , ("ncurses", any_c_p "sys-libs" "ncurses") , ("panel", any_c_p "sys-libs" "ncurses") , ("nanomsg", any_c_p "dev-libs" "nanomsg")+ , ("pgf", any_c_p "media-libs" "libpgf")+ , ("ssh2", any_c_p "net-libs" "libssh2")+ , ("dl", any_c_p "virtual" "libc") ] ---------------------------------------------------------------@@ -482,4 +485,6 @@ ,("ncursesw", ("sys-libs", "ncurses", Portage.AnySlot)) ,("panel", ("sys-libs", "ncurses", Portage.AnySlot)) ,("panelw", ("sys-libs", "ncurses", Portage.AnySlot))+ ,("libssh2", ("net-libs", "libssh2", Portage.AnySlot))+ ,("SDL_image", ("media-libs", "sdl-image", Portage.AnySlot)) ]
Portage/Dependency/Normalize.hs view
@@ -3,12 +3,14 @@ normalize_depend ) where +import qualified Control.Arrow as A import Control.Monad import qualified Data.List as L+import qualified Data.Set as S import Data.Maybe -import Portage.Dependency.Types import Portage.Dependency.Builder+import Portage.Dependency.Types import Portage.Use import Debug.Trace@@ -26,16 +28,33 @@ d' = pass d -- remove one layer of redundancy-normalization_step :: Dependency -> Dependency-normalization_step = combine_atoms- . stabilize_pass propagate_context- . stabilize_pass flatten- . lift_context- . stabilize_pass remove_duplicates- . stabilize_pass remove_empty- . sort_deps- . combine_use_guards- . stabilize_pass flatten+normalization_step :: Int -> Dependency -> Dependency+normalization_step level =+ id+ . tp "PC2" (stabilize_pass propagate_context)+ . tp "F3" (stabilize_pass flatten)+ . tp "LC" lift_context+ . tp "PC1" (stabilize_pass propagate_context)+ . tp "F2" (stabilize_pass flatten)+ . tp "RD" (stabilize_pass remove_duplicates)+ . tp "RE" (stabilize_pass remove_empty)+ . tp "SD" sort_deps+ . tp "CUG" combine_use_guards+ . tp "F1" (stabilize_pass flatten)+ . tp "CAR" combine_atom_ranges+ where tp :: String -> (Dependency -> Dependency) -> Dependency -> Dependency+ tp pass_name pass d = t False d'+ where d' = pass d+ t False = id+ t True =+ trace (unwords [ "PASS"+ , show level+ , ":"+ , pass_name+ , show (length (show d))+ , "->"+ , show (length (show d'))+ ]) remove_empty :: Dependency -> Dependency remove_empty d =@@ -50,13 +69,16 @@ DependAtom _ -> d where go = remove_empty --- Ideally 'combine_atoms' should handle those as well+s_uniq :: [Dependency] -> [Dependency]+s_uniq = S.toList . S.fromList++-- Ideally 'combine_atom_ranges' should handle those as well remove_duplicates :: Dependency -> Dependency remove_duplicates d = case d of 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+ DependAnyOf deps -> DependAnyOf $ s_uniq $ map go deps+ DependAllOf deps -> DependAllOf $ s_uniq $ map go deps DependAtom _ -> d where go = remove_duplicates @@ -69,11 +91,11 @@ DependAnyOf [dep] -> go dep DependAnyOf deps -> DependAnyOf $ map go deps - DependAllOf deps -> case L.partition is_dall_of (map go deps) of+ DependAllOf deps -> case L.partition is_dall_of deps of ([], []) -> empty_dependency ([], [dep]) -> dep- ([], ndall) -> DependAllOf ndall- (dall, ndall) -> go $ DependAllOf $ (concatMap undall dall) ++ ndall+ ([], ndall) -> DependAllOf $ map go ndall+ (dall, ndall) -> go $ DependAllOf $ s_uniq $ (concatMap undall dall) ++ ndall DependAtom _ -> d where go :: Dependency -> Dependency go = flatten@@ -88,14 +110,14 @@ -- 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 =+combine_atom_ranges :: Dependency -> Dependency+combine_atom_ranges d = case d of 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 DependAtom _ -> d- where go = combine_atoms+ where go = combine_atom_ranges find_atom_intersections :: [Dependency] -> [Dependency] find_atom_intersections = map merge_depends . L.groupBy is_mergeable@@ -167,8 +189,7 @@ 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+ common_ctx -> stabilize_pass flatten $ DependAllOf $ propagate_context' common_ctx d' : common_ctx where td_ctx = lift_context' td fd_ctx = lift_context' fd pop_common x = x@@ -184,6 +205,13 @@ -- gets translated to -- foo/bar -- u? ( bar/baz )+--+-- and more complex redundancy:+-- v? ( foo/bar )+-- u? ( !v? ( foo/bar ) )+-- gets translated to+-- v? ( foo/bar )+-- u? ( foo/bar ) propagate_context :: Dependency -> Dependency propagate_context = propagate_context' [] @@ -193,8 +221,23 @@ propagate_context' :: [Dependency] -> Dependency -> Dependency propagate_context' ctx d = case d of- DependIfUse use td fd -> DependIfUse use (go (refine_context (True, use) ctx) td)- (go (refine_context (False, use) ctx) fd)+ _ | d `elem` ctx -> empty_dependency+ DependIfUse use td fd -> let (t_ctx_comp, t_refined_ctx) = refine_context (True, use) ctx+ (f_ctx_comp, f_refined_ctx) = refine_context (False, use) ctx+ tdr = go t_refined_ctx td+ fdr = go f_refined_ctx fd+ ctx_comp = filter (not . is_empty_dependency) $+ concat [ (lift_context' tdr `L.intersect` (concatMap lift_context' t_ctx_comp))+ , (lift_context' fdr `L.intersect` (concatMap lift_context' f_ctx_comp))+ ]+ diu_refined = DependIfUse use tdr+ fdr+ in case ctx_comp of+ [] -> diu_refined+ _ -> go ctx $+ DependAllOf [ DependAllOf ctx_comp+ , go ctx_comp diu_refined+ ] DependAllOf deps -> DependAllOf $ fromJust $ msum $ [ v | (optimized_d, other_deps) <- slice_list deps@@ -210,19 +253,22 @@ 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+-- returns (complement-dependencies, simplified-dependencies)+refine_context :: (Bool, Use) -> [Dependency] -> ([Dependency], [Dependency])+refine_context use_cond = unzip . map (A.second (stabilize_pass flatten) . refine_ctx_unit use_cond)+ where refine_ctx_unit :: (Bool, Use) -> Dependency -> (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+ False -> ( empty_dependency+ , DependIfUse u' (snd $ refine_ctx_unit uc td)+ (snd $ refine_ctx_unit uc fd)+ )+ True -> case bu of+ True -> (fd, snd $ refine_ctx_unit uc td)+ False -> (td, snd $ refine_ctx_unit uc fd)+ _ -> (empty_dependency, d) -- generates all pairs of: -- (list_element, list_without_element)@@ -247,7 +293,7 @@ -- foo/bar -- || ( bar/baz -- bar/quux )--- TODO: better add propagation in this exact plase to keep tree shrinking only+-- TODO: better add propagation in this exact place to keep tree shrinking only lift_context :: Dependency -> Dependency lift_context d = case d of@@ -273,7 +319,7 @@ case d of 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+ DependAnyOf deps -> d : extract_common_constraints (map lift_context' deps) DependAtom _ -> [d] -- it extracts common part of dependency comstraints.@@ -340,11 +386,12 @@ -- remove various types of redundancy normalize_depend :: Dependency -> Dependency-normalize_depend = normalize_depend' 50 -- arbitrary limit+normalize_depend = normalize_depend' 50 0 -- 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+normalize_depend' :: Int -> Int -> Dependency -> Dependency+normalize_depend' max_level level d+ | level >= max_level = trace "WARNING: Normalize_depend hung up. Optimization is incomplete." d+normalize_depend' max_level level d = next_step next_d+ where next_d = normalization_step level d next_step | d == next_d = id- | otherwise = normalize_depend' (level - 1)+ | otherwise = normalize_depend' max_level (level + 1)
Portage/Dependency/Types.hs view
@@ -76,9 +76,9 @@ deriving (Eq, Show, Ord) data Dependency = DependAtom Atom- | DependIfUse Use Dependency Dependency -- u? ( td ) !u? ( fd ) | DependAnyOf [Dependency] | DependAllOf [Dependency]+ | DependIfUse Use Dependency Dependency -- u? ( td ) !u? ( fd ) deriving (Eq, Show, Ord) data Atom = Atom PackageName DRange DAttr deriving (Eq, Show, Ord)
Portage/EBuild.hs view
@@ -100,7 +100,7 @@ Nothing -> id Just pn -> ss "MY_PN=". quote pn. nl. ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl).- ss "DESCRIPTION=". quote (description ebuild). nl.+ ss "DESCRIPTION=". quote (drop_tdot $ description ebuild). nl. ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl. ss "SRC_URI=". quote (toMirror $ src_uri ebuild). nl. nl.@@ -136,6 +136,10 @@ sort_iuse :: [String] -> [String] sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` "+")) +-- drops trailing dot+drop_tdot :: String -> String+drop_tdot = reverse . dropWhile (== '.') . reverse+ type DString = String -> String ss :: String -> DString@@ -184,8 +188,12 @@ quote str = sc '"'. ss (esc str). sc '"' where esc = concatMap esc'- esc' '"' = "\""- esc' c = [c]+ esc' c =+ case c of+ '"' -> "\""+ '\n' -> " "+ '`' -> "'"+ _ -> [c] quote' :: DString -> DString quote' str = sc '"'. str. sc '"'
Portage/Metadata.hs view
@@ -36,9 +36,6 @@ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">" , "<pkgmetadata>" , "\t<herd>haskell</herd>"- , "\t<maintainer>"- , "\t\t<email>haskell@gentoo.org</email>"- , "\t</maintainer>" , (init {- strip trailing newline-} . unlines . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]
Progress.hs view
@@ -4,7 +4,6 @@ -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like ----- Maintainer : duncan@haskell.org -- Portability : portable -- -- Common types for dependency resolution.
Status.hs view
@@ -194,8 +194,10 @@ putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay" putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree" putStrLn $ toColor (HackageOnly "Cyan") ++ ": package only exist on hackage"- forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do+ forM_ (zip [(1 :: Int) ..] $ Map.toAscList packages) $ \(ix, (pkg, ebuilds)) -> do let (PackageName c p) = pkg+ putStr (bold (show ix))+ putStr " " putStr $ display c ++ '/' : bold (display p) putStr " " forM_ ebuilds $ \e -> do
hackport.cabal view
@@ -1,5 +1,5 @@ Name: hackport-Version: 0.4.2+Version: 0.4.3 License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin
tests/normalize_deps.hs view
@@ -185,6 +185,60 @@ , [ "b? ( c/d )" ] )+ , -- pop '|| ( some thing )' depend+ ( let any_part = d_any $ map d_p ["a", "b"] in+ d_all [ d_use "u" $ d_all [ any_part , d_p "z"]+ , d_nuse "u" $ any_part+ ]+ , [ "|| ( c/a"+ , " c/b )"+ , "u? ( c/z )"+ ]+ )+ , -- simplify slightly more complex counterguard+ -- v? ( c/d )+ -- u? ( !v? ( c/d ) )+ -- to+ -- v? ( c/d )+ -- u? ( c/d )+ ( d_all [ d_use "v" $ d_p "d"+ , d_use "u" $ d_nuse "v" $ d_p "d"+ ]+ , [ "u? ( c/d )"+ , "v? ( c/d )"+ ]+ )++ , -- ffi? ( c/d c/e )+ -- !ffi ( !gmp ( c/d c/e ) )+ -- gmp? ( c/d c/e )+ -- to+ -- ( c/d c/e )+ ( let de = d_all [ d_p "d" , d_p "e" ]+ in d_all [ d_use "ffi" de+ , d_nuse "ffi" $ d_nuse "gmp" $ de+ , d_use "gmp" $ de+ ]+ , [ "c/d"+ , "c/e"+ ]+ )++ {- TODO: another popular case+ , -- simplify even more complex counterguard+ -- u? ( c/d )+ -- !u? ( v? ( c/d ) )+ -- to+ -- u? ( c/d )+ -- v? ( c/d )+ ( d_all [ d_use "u" $ d_p "d"+ , d_nuse "u" $ d_use "v" $ d_p "d"+ ]+ , [ "u? ( c/d )"+ , "v? ( c/d )"+ ]+ )+ -} ] forM_ deps $ \(d, expected) -> let actual = P.dep2str 0 $ PN.normalize_depend d