haskell-updater 1.2.0.12 → 1.2.1

raw patch · 6 files changed

+80/−58 lines, 6 files

Files

• Distribution/Gentoo/GHC.hs +44/−37
• Distribution/Gentoo/Packages.hs +8/−11
• Distribution/Gentoo/PkgManager.hs +1/−1
• Main.hs +10/−4
• Output.hs +16/−4
• haskell-updater.cabal +1/−1

@@ -39,6 +39,9 @@                        , doesDirectoryExist                        , findExecutable) import Control.Monad(foldM, liftM)++import Output+ -- -----------------------------------------------------------------------------  -- Common helper utils, etc.@@ -129,49 +132,50 @@     cfNm :: [([InstalledPackageInfo_ String], String)] -> PackageIdentifier     cfNm = packageId . head . fst . head -checkPkgs :: ([PackageIdentifier], [FilePath])+checkPkgs :: Verbosity+             -> ([PackageIdentifier], [FilePath])              -> IO ([Package],[PackageIdentifier],[FilePath])-checkPkgs (pns,cnfs)-  = do (nI, pkgs) <- liftM partitionEithers $ mapM hasFile' cnfs-       return (pkgs, pns, nI)-    where-      hasFile' f = do mp <- hasFile f-                      return $ maybe (Left f) Right mp+checkPkgs v (pns,cnfs)+  = do pkgs <- haveFiles cnfs+       return (pkgs, pns, [])  -- -----------------------------------------------------------------------------  -- Finding packages installed with other versions of GHC-oldGhcPkgs :: IO [Package]-oldGhcPkgs = do thisGhc <- ghcLibDir-                let thisGhc' = BS.pack thisGhc-                -- It would be nice to do this, but we can't assume-                -- some crazy user hasn't deleted one of these dirs-                -- libFronts' <- filterM doesDirectoryExist libFronts-                pkgs <- liftM notGHC-                        $ concatMapM (checkLibDir thisGhc') libFronts-                return pkgs+oldGhcPkgs :: Verbosity -> IO [Package]+oldGhcPkgs v =+    do thisGhc <- ghcLibDir+       vsay v $ "oldGhcPkgs ghc lib: " ++ show thisGhc+       let thisGhc' = BS.pack thisGhc+       -- It would be nice to do this, but we can't assume+       -- some crazy user hasn't deleted one of these dirs+       -- libFronts' <- filterM doesDirectoryExist libFronts+       pkgs <- liftM notGHC+               $ checkLibDirs v thisGhc' libFronts+       return pkgs  -- Find packages installed by other versions of GHC in this possible -- library directory.-checkLibDir                :: BSFilePath -> BSFilePath -> IO [Package]-checkLibDir thisGhc libDir = pkgsHaveContent (hasDirMatching wanted)+checkLibDirs :: Verbosity -> BSFilePath -> [BSFilePath] -> IO [Package]+checkLibDirs v thisGhc libDirs =+    do vsay v $ "checkLibDir ghc libs: " ++ show (thisGhc, libDirs)+       pkgsHaveContent (hasDirMatching wanted)   where     wanted dir = isValid dir && (not . isInvalid) dir -    isValid = isGhcLibDir libDir+    isValid dir = any (\ldir -> isGhcLibDir ldir dir) libDirs      -- Invalid if it's this GHC     isInvalid fp = fp == thisGhc || BS.isPrefixOf (thisGhc `BS.snoc` pathSeparator) fp  -- A valid GHC library directory starting at libdir has a name of--- either "ghc" or "ghc-bin", then a hyphen and then a version number.-isGhcLibDir            :: BSFilePath -> BSFilePath -> Bool-isGhcLibDir libdir dir = go ghcDirName || go ghcBinDirName+-- "ghc", then a hyphen and then a version number.+isGhcLibDir :: BSFilePath -> BSFilePath -> Bool+isGhcLibDir libdir dir = go ghcDirName   where     -- This is hacky because FilePath doesn't work on Bytestrings...     libdir' = BS.snoc libdir pathSeparator     ghcDirName = BS.pack "ghc"-    ghcBinDirName = BS.pack "ghc-bin"      go dn = BS.isPrefixOf ghcDir dir             -- Any possible version starts with a digit@@ -184,26 +188,29 @@ -- The possible places GHC could have installed lib directories libFronts :: [BSFilePath] libFronts = map BS.pack-            $ do loc <- ["usr", "opt" </> "ghc"]-                 lib <- ["lib", "lib64"]-                 return $ "/" </> loc </> lib+            $ do lib <- ["lib", "lib64"]+                 return $ "/" </> "usr" </> lib  -- -----------------------------------------------------------------------------  -- Finding broken packages in this install of GHC.-brokenPkgs :: IO ([Package],[PackageIdentifier],[FilePath])-brokenPkgs = brokenConfs >>= checkPkgs+brokenPkgs :: Verbosity -> IO ([Package],[PackageIdentifier],[FilePath])+brokenPkgs v = brokenConfs v >>= checkPkgs v  -- .conf files from broken packages of this GHC version-brokenConfs :: IO ([PackageIdentifier], [FilePath])-brokenConfs = do brkn <- getBroken-                 -- Check if we actually have to go look up files and-                 -- do IO.-                 if null brkn-                   then return ([], [])-                   else do cnfs <- readConf-                           return $ partitionEithers-                                      $ map (matchConf cnfs) brkn+brokenConfs :: Verbosity -> IO ([PackageIdentifier], [FilePath])+brokenConfs v =+    do vsay v "brokenConfs: getting broken output from 'ghc-pkg'"+       brkn <- getBroken+       -- Check if we actually have to go look up files and+       -- do IO.+       vsay v $ "brokenConfs: resolving package names to gentoo equivalents. " ++ show (length brkn) ++ " are broken"+       if null brkn+           then return ([], [])+           else do vsay v "brokenConfs: reading '*.conf' files"+                   cnfs <- readConf+                   vsay v $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files"+                   return $ partitionEithers $ map (matchConf cnfs) brkn  -- Return the closure of all packages affected by breakage getBroken :: IO [PackageIdentifier]

@@ -12,7 +12,7 @@        , Content        , notGHC        , printPkg-       , hasFile+       , haveFiles        , pkgsHaveContent        , hasContentMatching        , hasDirMatching@@ -26,6 +26,7 @@ import Data.Maybe(mapMaybe, listToMaybe) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Char8(ByteString)+import qualified Data.Set as S import System.Directory( doesDirectoryExist                        , doesFileExist) import System.FilePath((</>))@@ -56,12 +57,9 @@ ghcPkg :: Package ghcPkg = Package "dev-lang" "ghc" Nothing -ghcBinPkg :: Package-ghcBinPkg = Package "dev-lang" "ghc-bin" Nothing- -- Return all packages that are not a version of GHC. notGHC :: [Package] -> [Package]-notGHC = filter (\p -> isNot ghcPkg p && isNot ghcBinPkg p)+notGHC = filter (\p -> isNot ghcPkg p)   where     isNot p1 = not . samePackageAs p1 @@ -179,13 +177,12 @@  -- ----------------------------------------------------------------------------- --- Find the package (if any) that contain this file.--- Assumes collision protection (i.e. at most one package per file).-hasFile    :: FilePath -> IO (Maybe Package)-hasFile fp = liftM listToMaybe $ pkgsHaveContent p+-- Find all the packages that contain any of the given files.+haveFiles :: [FilePath] -> IO [Package]+haveFiles fps = pkgsHaveContent p   where-    fp' = BS.pack fp-    p = hasObjMatching ((==) fp')+    fps' = S.fromList $ map BS.pack fps+    p = hasObjMatching (\fp -> S.member fp fps')  -- Find which packages have Content information that matches the -- provided predicate; to be used with the searching predicates

@@ -144,4 +144,4 @@ cavePMFlag PretendBuild   = Just "--no-execute" cavePMFlag UpdateDeep     = Just "--complete" cavePMFlag UpdateAsNeeded = Just "--lazy"-cavePMFlag PMQuiet        = Just "--quiet"+cavePMFlag PMQuiet        = Nothing -- Just "--quiet"

@@ -91,7 +91,7 @@ getPackages v target =     case target of         GhcUpgrade -> do say v "Searching for packages installed with a different version of GHC."-                         pkgs <- oldGhcPkgs+                         pkgs <- oldGhcPkgs v                          pkgListPrint v "old" pkgs                          return pkgs @@ -100,8 +100,8 @@                            pkgListPrint v "installed" pkgs                            return pkgs -        DepCheck   -> do say v  "Searching for Haskell libraries with broken dependencies."-                         (pkgs, unknown_packages, unknown_files)  <- brokenPkgs+        DepCheck   -> do say v "Searching for Haskell libraries with broken dependencies."+                         (pkgs, unknown_packages, unknown_files) <- brokenPkgs v                          printUnknownPackages unknown_packages                          printUnknownFiles unknown_files                          pkgListPrint v "broken" (notGHC pkgs)@@ -169,6 +169,7 @@           | Pretend           | NoDeep           | QuietFlag+          | VerboseFlag           | ListOnlyFlag           deriving (Eq, Ord, Show, Read) @@ -199,7 +200,10 @@                 -- We need to get Flags that represent this as well.               , withCmd  = PrintAndRun               , rawPMArgs = nonoptions-              , verbosity = bool Normal Quiet (hasFlag QuietFlag)+              , verbosity = case () of+                                _ | hasFlag VerboseFlag -> Verbose+                                _ | hasFlag QuietFlag   -> Quiet+                                _                       -> Normal               , listOnly  = hasFlag ListOnlyFlag               } @@ -240,6 +244,8 @@       "Version information."     , Option ['q']      ["quiet"]           (NoArg QuietFlag)       "Print only fatal errors (to stderr)."+    , Option ['v']      ["verbose"]         (NoArg VerboseFlag)+      "Be more elaborate (to stderr)."     , Option ['h', '?'] ["help"]            (NoArg HelpFlag)       "Print this help message."     ]

@@ -9,6 +9,7 @@                 pkgListPrint               , printList               , say+              , vsay               , Verbosity(..)               ) where @@ -17,13 +18,24 @@ import Distribution.Gentoo.Packages  -- output mode (chattiness)-data Verbosity = Normal-               | Quiet+data Verbosity = Quiet+               | Normal+               | Verbose      deriving (Eq, Ord, Show, Read)  say :: Verbosity -> String -> IO ()-say Normal msg = hPutStrLn stderr msg-say Quiet _msg = return ()+say verb_l msg =+    case verb_l of+        Quiet   -> return ()+        Normal  -> hPutStrLn stderr msg+        Verbose -> hPutStrLn stderr msg++vsay :: Verbosity -> String -> IO ()+vsay verb_l msg =+    case verb_l of+        Quiet   -> return ()+        Normal  -> return ()+        Verbose -> hPutStrLn stderr msg  -- Print a bullet list of values with one value per line. printList :: Verbosity -> (a -> String) -> [a] -> IO ()

@@ -1,6 +1,6 @@ Name:                haskell-updater Homepage:            http://haskell.org/haskellwiki/Gentoo#haskell-updater-Version:             1.2.0.12+Version:             1.2.1 Synopsis:            Rebuild Haskell dependencies in Gentoo Description:         haskell-updater rebuilds Haskell packages on Gentoo                      after a GHC upgrade or a dependency upgrade.