[Pkg-haskell-commits] darcs: tools: Use Data.HashMap (but not noticable speed up)
Joachim Breitner
mail at joachim-breitner.de
Sat Jun 4 13:20:06 UTC 2011
Sat Jun 4 13:07:06 UTC 2011 Joachim Breitner <mail at joachim-breitner.de>
* Use Data.HashMap (but not noticable speed up)
Ignore-this: 155c90e8c7f3000e98026e574a5458ee
M ./haskell-pkg-debcheck.hs -15 +37
Sat Jun 4 13:07:06 UTC 2011 Joachim Breitner <mail at joachim-breitner.de>
* Use Data.HashMap (but not noticable speed up)
Ignore-this: 155c90e8c7f3000e98026e574a5458ee
diff -rN -u old-tools//haskell-pkg-debcheck.hs new-tools//haskell-pkg-debcheck.hs
--- old-tools//haskell-pkg-debcheck.hs 2011-06-04 13:20:06.865295298 +0000
+++ new-tools//haskell-pkg-debcheck.hs 2011-06-04 13:20:06.893289585 +0000
@@ -4,9 +4,11 @@
import System.Process
import Control.Monad
import Control.Applicative
+import Data.Functor.Identity
import Data.Maybe
import Data.List
import Data.List.Split
+import Data.Hashable
import System.IO
import Text.XML.HaXml hiding ((!),when)
import Text.XML.HaXml.Posn (noPos)
@@ -20,7 +22,7 @@
import Debian.Relation.ByteString
import Debian.Version
import Debian.Version.ByteString
-import qualified Data.Map as M
+import qualified Data.HashMap.Lazy as M
-- import Data.Map ((!))
import qualified Data.Set as S
import Debug.Trace
@@ -69,7 +71,7 @@
hPutStr stderr "# Reading binaries..."
binaryMap <-
- fmap M.unions $
+ fmap unions $
forM arches $ \arch ->
toBinaryMap arch bToS <$>
(either (error.show) id) <$>
@@ -82,7 +84,7 @@
hPutStr stderr "# Reading Wanna-Build-State..."
wbMap <-
- fmap M.unions $
+ fmap unions $
forM arches $ \arch ->
toWBMap arch sourcesMap <$>
(either (error.show) id) <$>
@@ -105,14 +107,14 @@
let nmus = M.fromListWith mergeArches $ do
(p,a,_,x) <- problems
- guard $ (p,a) `M.member` binaryMap
+ guard $ (p,a) `member` binaryMap
let s = bToS ! p
si = sourcesMap ! s
(_,bsv) = binaryMap ! (p,a)
sv = siVersion si
-- Do not schedule binNMUs for outdated sources
guard (bsv == sv)
- --guard (not (s `M.member` outdatedSources))
+ --guard (not (s `member` outdatedSources))
-- Do not scheulde binNMUs if not in Installed state
guard (fst (wbMap ! (s,a)) == "Installed")
@@ -120,31 +122,31 @@
forM (M.toList nmus) $ \(s,(as,sv,exp)) -> putStrLn $ "nmu " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "'"
- let buildingSources = M.unionWith mergeArches outdatedSources nmus
+ let buildingSources = unionWith mergeArches outdatedSources nmus
let depwaits = filterExistingDepWaits wbMap $
- M.fromListWith (M.unionWith mergeRelations) $ do
+ M.fromListWith (unionWith mergeRelations) $ do
(s,(as,sv,_)) <- M.toList buildingSources
a <- S.toList as
bdep <- flattenRelations (siBuildDepends (sourcesMap ! s))
guard (isNotIgnored bdep)
- guard (bdep `M.member` bToS)
+ guard (bdep `member` bToS)
let dsi = sourcesMap ! (bToS ! bdep)
dw <-
(do
-- DepWait upon packages that are yet to be built
- guard $ siName dsi `M.member` outdatedSources
+ guard $ siName dsi `member` outdatedSources
-- on this architecute
guard $ a `S.member` (let (as,_,_) = outdatedSources ! siName dsi in as)
-- unless this package is non-existant on this architecture
- guard $ (bdep,a) `M.member` binaryMap
+ guard $ (bdep,a) `member` binaryMap
let dwv = siVersion dsi
return $ [[(Rel bdep (Just (GRE dwv)) Nothing )]]
) ++
(do
- guard $ siName dsi `M.member` nmus
+ guard $ siName dsi `member` nmus
guard $ a `S.member` (let (as,_,_) = nmus ! siName dsi in as)
- guard $ (bdep,a) `M.member` binaryMap
+ guard $ (bdep,a) `member` binaryMap
let dwv = fst (binaryMap ! (bdep,a))
return $ [[(Rel bdep (Just (SGR dwv)) Nothing)]]
)
@@ -201,7 +203,7 @@
mapMaybe (\para -> do -- Maybe monad
p <- BS.unpack <$>
fieldValue "Package" para
- guard (p `M.member` bToS)
+ guard (p `member` bToS)
guard (isNotIgnored p)
v <- parseDebianVersion <$>
fieldValue "Version" para
@@ -221,7 +223,7 @@
mapMaybe (\para -> do -- Maybe monad
s <- BS.unpack <$>
fieldValue "package" para
- guard (s `M.member` sourcesMap)
+ guard (s `member` sourcesMap)
v <- parseDebianVersion <$>
fieldValue "version" para
-- Consider all the posibilities here: What if wanna-build is newer,
@@ -276,7 +278,7 @@
where lastLine = last (lines s)
packageName = drop 4 lastLine
-filterExistingDepWaits wbMap = M.mapWithKey $ \(s,v) -> M.mapWithKey $ \a dw ->
+filterExistingDepWaits wbMap = mapWithKey $ \(s,v) -> mapWithKey $ \a dw ->
case (s,a) `M.lookup` wbMap of
Just (_,cdw@(_:_)) -> if cdw `impliesRelations` dw
then (False, dw)
@@ -331,3 +333,23 @@
samePkg (Rel p1 _ _) (Rel p2 _ _) = p1 == p2
showRelations = intercalate ", " . map (intercalate " | " . map show)
+
+-- Functions from Data.Map missing in Data.HashMap
+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))
+
+instance Hashable DebianVersion where
+ hashWithSalt s = hashWithSalt s . evr
+instance Hashable Relation where
+ hashWithSalt s (Rel n r a) = hashWithSalt s (n,r,a)
+instance Hashable ArchitectureReq where
+ hashWithSalt s (ArchOnly as) = hashWithSalt s (1::Int,as)
+ hashWithSalt s (ArchExcept as) = hashWithSalt s (2::Int,as)
+instance Hashable VersionReq where
+ hashWithSalt s (SLT v) = hashWithSalt s (1::Int,v)
+ hashWithSalt s (LTE v) = hashWithSalt s (2::Int,v)
+ 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)
More information about the Pkg-haskell-commits
mailing list