[Pkg-haskell-commits] darcs: tools: Port ./haskell-pkg-debcheck.hs to latest version of Debian
Joachim Breitner
mail at joachim-breitner.de
Sat Nov 9 08:14:30 UTC 2013
Wed Oct 30 08:43:17 UTC 2013 Joachim Breitner <mail at joachim-breitner.de>
* Port ./haskell-pkg-debcheck.hs to latest version of Debian
M ./haskell-pkg-debcheck.hs -29 +55
M ./make-static-binary.sh -1 +1
Wed Oct 30 08:43:17 UTC 2013 Joachim Breitner <mail at joachim-breitner.de>
* Port ./haskell-pkg-debcheck.hs to latest version of Debian
diff -rN -u old-tools/haskell-pkg-debcheck.hs new-tools/haskell-pkg-debcheck.hs
--- old-tools/haskell-pkg-debcheck.hs 2013-11-09 08:14:30.235075992 +0000
+++ new-tools/haskell-pkg-debcheck.hs 2013-11-09 08:14:30.555063371 +0000
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveGeneric, ScopedTypeVariables #-}
import System.Directory
import System.Process
@@ -18,14 +18,16 @@
import qualified Codec.Compression.GZip as GZip
import Debian.Control
import Debian.Control.ByteString
-import Debian.Relation
+import Debian.Relation hiding (Arch)
import Debian.Relation.ByteString
import Debian.Version
import Debian.Version.ByteString
+import qualified Debian.Arch
import qualified Data.HashMap.Lazy as M
-- import Data.Map ((!))
import qualified Data.HashSet as S
import Debug.Trace
+import GHC.Generics
import Text.Printf
m ! k = case M.lookup k m of
@@ -34,32 +36,38 @@
type Arch = String
+
arches :: [Arch]
--arches = ["amd64", "i386"]
-arches = words "amd64 armel armhf hurd-i386 i386 mips mipsel powerpc s390 s390x sparc kfreebsd-amd64 kfreebsd-i386"
-
+arches = words "amd64 armel armhf hurd-i386 i386 mips mipsel powerpc s390x sparc kfreebsd-amd64 kfreebsd-i386"
-- File locations
sourcesFile = "data/unstable-main-Sources.gz"
binariesFiles arch = "data/unstable-main-binary-" ++ arch ++ "-Packages.gz"
wbDump arch = "data/wanna-build-dump-" ++ arch ++ ".gz"
-instance Show DebianVersion where show v = render (prettyDebianVersion v)
-instance Show Relation where show v = render (prettyRelation v)
+--instance Show DebianVersion where show v = render (prettyDebianVersion v)
+--instance Show Relation where show v = render (prettyRelation v)
data SourceInfo = SourceInfo
- { siName :: PkgName
+ { siName :: SrcPkgName
, siVersion :: DebianVersion
- , siBinaries :: [PkgName]
+ , siBinaries :: [BinPkgName]
, siBuildDepends :: Relations
}
deriving Show
+type SourcesMap = M.HashMap SrcPkgName SourceInfo
+type BinaryMap = M.HashMap (BinPkgName, Arch) (DebianVersion, DebianVersion)
+type BToS = M.HashMap BinPkgName SrcPkgName
+type WBMap = M.HashMap (SrcPkgName, Arch) ([Char], [OrRelation])
+type CFile = Control' BS.ByteString
+
main = do
checkFiles
hPutStr stderr "# Reading sources..."
- sourcesMap <-
+ (sourcesMap :: SourcesMap) <-
toSourcesMap <$>
(either (error.show) id) <$>
parseControl "Sources" <$>
@@ -73,7 +81,7 @@
let bToS = M.fromList $ concat $ map (\(_,si) -> map (\p -> (p,siName si)) (siBinaries si)) $ M.toList sourcesMap
hPutStr stderr "# Reading binaries..."
- binaryMap <-
+ (binaryMap :: BinaryMap) <-
fmap unions $
forM arches $ \arch ->
toBinaryMap arch bToS <$>
@@ -86,7 +94,7 @@
hPutStrLn stderr $ show (M.size binaryMap) ++ " binary/arch tuples selected."
hPutStr stderr "# Reading Wanna-Build-State..."
- wbMap <-
+ (wbMap :: WBMap) <-
fmap unions $
forM arches $ \arch ->
toWBMap arch sourcesMap <$>
@@ -123,7 +131,7 @@
guard (fst (wbMap ! (s,a)) == "Installed")
return (s,(S.singleton a, sv, formatReason x))
- forM (M.toList nmus) $ \(s,(as,sv,exp)) -> putStrLn $ "nmu " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "'"
+ forM (M.toList nmus) $ \(s,(as,sv,exp)) -> putStrLn $ "nmu " ++ show s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "'"
let buildingSources = unionWith mergeArches outdatedSources nmus
@@ -168,20 +176,21 @@
_ -> return ()
when (not f) $ putStr "# "
-}
- when f $ putStrLn $ "dw " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ showRelations dws ++ "'"
+ when f $ putStrLn $ "dw " ++ show s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ showRelations dws ++ "'"
-interestingSource si = "haskell-devscripts" `elem` (flattenRelations (siBuildDepends si)) &&
- "ghc6" `notElem` (flattenRelations (siBuildDepends si))
+interestingSource si = BinPkgName "haskell-devscripts" `elem` (flattenRelations (siBuildDepends si)) &&
+ BinPkgName "ghc6" `notElem` (flattenRelations (siBuildDepends si))
mergeArches n1@(as1, v1, x1) n2@(as2, v2, x2)
| v1 == v2 = (as1 `S.union` as2, v1, x1)
| v1 > v2 = n1
| v1 < v2 = n2
+toSourcesMap :: CFile -> SourcesMap
toSourcesMap =
M.fromListWith higherSourceVersion .
mapMaybe (\para -> do -- Maybe monad
- p <- BS.unpack <$> fieldValue "Package" para
+ p <- (SrcPkgName . BS.unpack) <$> fieldValue "Package" para
a <- BS.unpack <$> fieldValue "Architecture" para
guard (a /= "all")
v <- parseDebianVersion <$>
@@ -201,10 +210,11 @@
) .
unControl
+toBinaryMap :: Arch -> BToS -> CFile -> BinaryMap
toBinaryMap arch bToS =
M.fromList .
mapMaybe (\para -> do -- Maybe monad
- p <- BS.unpack <$>
+ p <- (BinPkgName . BS.unpack) <$>
fieldValue "Package" para
guard (p `member` bToS)
guard (isNotIgnored p)
@@ -214,17 +224,18 @@
fieldValue "Source" para
-- extract the source name and version if both are given
let (s,sv) = case words sf of
- [s,('(':sv)] -> (s, parseDebianVersion (init sv))
- [s] -> (s,v)
+ [s,('(':sv)] -> (SrcPkgName s, parseDebianVersion (init sv))
+ [s] -> (SrcPkgName s,v)
guard (s == bToS ! p)
return ((p,arch), (v,sv))
) .
unControl
+toWBMap :: Arch -> SourcesMap -> CFile -> WBMap
toWBMap arch sourcesMap =
M.fromList .
mapMaybe (\para -> do -- Maybe monad
- s <- BS.unpack <$>
+ s <- (SrcPkgName . BS.unpack) <$>
fieldValue "package" para
guard (s `member` sourcesMap)
v <- parseDebianVersion <$>
@@ -237,7 +248,7 @@
unless (st `elem` ["Failed-Removed", "Not-For-Us"]) $
trace (printf "Version difference for %s on %s in state %s: \
\wb knows %s and Sources knows %s"
- s
+ (show s)
arch
st
(show v)
@@ -253,7 +264,7 @@
) .
unControl
-flattenRelations :: Relations -> [PkgName]
+flattenRelations :: Relations -> [BinPkgName]
flattenRelations = map (\(Rel p _ _) -> p) . concat
higherSourceVersion si1 si2 = if siVersion si1 > siVersion si2 then si1 else si2
@@ -265,20 +276,20 @@
unless ex $ do
hPutStrLn stderr $ "# Missing expected file: " ++ file
-collectEdosOutput :: [PkgName] -> IO [(PkgName, Arch, DebianVersion, String)]
+collectEdosOutput :: [BinPkgName] -> IO [(BinPkgName, Arch, DebianVersion, String)]
collectEdosOutput pkgs = fmap concat $ forM arches $ \arch -> do
(_, Just zcatOut, _, _) <- createProcess $ (proc "zcat" [binariesFiles arch]) { std_out = CreatePipe }
- (_, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-xml","-failures","-explain","-checkonly", intercalate "," pkgs]) { std_in = UseHandle zcatOut, std_out = CreatePipe }
+ (_, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-xml","-failures","-explain","-checkonly", intercalate "," (map unBinPkgName pkgs)]) { std_in = UseHandle zcatOut, std_out = CreatePipe }
Document _ _ root _ <- xmlParse "edos output" <$> hGetContents edosOut
-- How do you actually use this HaXmL? This can not be the correct way:
let filter = concatMap ((attributed "package" `x` attributed "architecture" `x` attributed "version" `x` extracted (concat . mapMaybe fst . textlabelled (txt `o` children)) ) keep) . (elm `o` children)
- return $ map (\((((p,a),v),s),_) -> (p, a, parseDebianVersion v, s)) (filter (CElem root noPos))
+ return $ map (\((((p,a),v),s),_) -> (BinPkgName p, a, parseDebianVersion v, s)) (filter (CElem root noPos))
-removeArchAll :: [(PkgName, Arch, DebianVersion, String)] -> [(PkgName, Arch, DebianVersion, String)]
+removeArchAll :: [(BinPkgName, Arch, DebianVersion, String)] -> [(BinPkgName, Arch, DebianVersion, String)]
removeArchAll = filter (\(_,a,_,_) -> a /= "all")
-isNotIgnored :: PkgName -> Bool
-isNotIgnored pkg = not ("-doc" `isSuffixOf` pkg || "-prof" `isSuffixOf` pkg)
+isNotIgnored :: BinPkgName -> Bool
+isNotIgnored pkg = not ("-doc" `isSuffixOf` unBinPkgName pkg || "-prof" `isSuffixOf` unBinPkgName pkg)
formatReason :: String -> String
formatReason s = "Dependency " ++ packageName ++ " not available any more"
@@ -342,15 +353,19 @@
showRelations = intercalate ", " . map (intercalate " | " . map show)
-- Functions from Data.Map missing in Data.HashMap
+unions :: (Hashable k, Eq k) => [M.HashMap k v] -> M.HashMap k v
unions = foldl M.union M.empty
member k = isJust . M.lookup k
unionWith f m1 m2 = M.foldrWithKey (M.insertWith f) m1 m2
mapWithKey f = runIdentity . M.traverseWithKey (\k v -> Identity (f k v))
+deriving instance Hashable SrcPkgName
+deriving instance Hashable BinPkgName
instance Hashable DebianVersion where
hashWithSalt s = hashWithSalt s . evr
instance Hashable Relation where
- hashWithSalt s (Rel n r a) = hashWithSalt s (n,r,a)
+ hashWithSalt s r = hashWithSalt s (show r)
+{-
instance Hashable ArchitectureReq where
hashWithSalt s (ArchOnly as) = hashWithSalt s (1::Int,as)
hashWithSalt s (ArchExcept as) = hashWithSalt s (2::Int,as)
@@ -360,6 +375,17 @@
hashWithSalt s (EEQ v) = hashWithSalt s (3::Int,v)
hashWithSalt s (GRE v) = hashWithSalt s (4::Int,v)
hashWithSalt s (SGR v) = hashWithSalt s (5::Int,v)
+-}
+
+{-
+deriving instance Generic Debian.Arch.Arch
+deriving instance Generic Debian.Arch.ArchOS
+deriving instance Generic Debian.Arch.ArchCPU
+instance Hashable Debian.Arch.ArchOS
+instance Hashable Debian.Arch.ArchCPU
+instance Hashable Debian.Arch.Arch
+deriving instance Hashable BinPkgName
+-}
--instance Show a => Show (S.HashSet a) where
-- show s = "fromList " ++ show (S.toList s)
diff -rN -u old-tools/make-static-binary.sh new-tools/make-static-binary.sh
--- old-tools/make-static-binary.sh 2013-11-09 08:14:29.553592062 +0000
+++ new-tools/make-static-binary.sh 2013-11-09 08:14:30.327042631 +0000
@@ -1,2 +1,2 @@
ghc -O2 -optl-static -optl-pthread -package transformers --make haskell-pkg-debcheck.hs
-ghc -O2 -optl-static -optl-pthread -package transformers --make haskell-pkg-debcheck-exp.hs
+#ghc -O2 -optl-static -optl-pthread -package transformers --make haskell-pkg-debcheck-exp.hs
More information about the Pkg-haskell-commits
mailing list