diff --git a/AnsiColor.hs b/AnsiColor.hs --- a/AnsiColor.hs +++ b/AnsiColor.hs @@ -1,5 +1,4 @@ {-| - Maintainer : Andres Loeh Stability : provisional Portability : haskell98 diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs --- a/Cabal2Ebuild.hs +++ b/Cabal2Ebuild.hs @@ -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 diff --git a/Merge.hs b/Merge.hs --- a/Merge.hs +++ b/Merge.hs @@ -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 $ diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs --- a/Merge/Dependencies.hs +++ b/Merge/Dependencies.hs @@ -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)) ] diff --git a/Portage/Dependency/Normalize.hs b/Portage/Dependency/Normalize.hs --- a/Portage/Dependency/Normalize.hs +++ b/Portage/Dependency/Normalize.hs @@ -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 " DRange ">=foo-1" " 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) diff --git a/Portage/Dependency/Types.hs b/Portage/Dependency/Types.hs --- a/Portage/Dependency/Types.hs +++ b/Portage/Dependency/Types.hs @@ -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) diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs --- a/Portage/EBuild.hs +++ b/Portage/EBuild.hs @@ -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 '"' diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs --- a/Portage/Metadata.hs +++ b/Portage/Metadata.hs @@ -36,9 +36,6 @@ , "" , "" , "\thaskell" - , "\t" - , "\t\thaskell@gentoo.org" - , "\t" , (init {- strip trailing newline-} . unlines . map (\l -> if l `elem` ["", ""] diff --git a/Progress.hs b/Progress.hs --- a/Progress.hs +++ b/Progress.hs @@ -4,7 +4,6 @@ -- Copyright : (c) Duncan Coutts 2008 -- License : BSD-like -- --- Maintainer : duncan@haskell.org -- Portability : portable -- -- Common types for dependency resolution. diff --git a/Status.hs b/Status.hs --- a/Status.hs +++ b/Status.hs @@ -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 diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -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 diff --git a/tests/normalize_deps.hs b/tests/normalize_deps.hs --- a/tests/normalize_deps.hs +++ b/tests/normalize_deps.hs @@ -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