[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