Internally, they're implemented using IntSets, which work quite well for both sparse and dense sets. The implementation is hidden outside the module so it's possible to replace it with something else, if needed.
Signed-off-by: Petr Pudlak <[email protected]> --- Makefile.am | 3 + src/Ganeti/Objects/BitArray.hs | 153 ++++++++++++++++++++++++++++++++ test/hs/Test/Ganeti/Objects/BitArray.hs | 102 +++++++++++++++++++++ test/hs/htest.hs | 2 + 4 files changed, 260 insertions(+) create mode 100644 src/Ganeti/Objects/BitArray.hs create mode 100644 test/hs/Test/Ganeti/Objects/BitArray.hs diff --git a/Makefile.am b/Makefile.am index 4aab1cf..cfc4cab 100644 --- a/Makefile.am +++ b/Makefile.am @@ -157,6 +157,7 @@ HS_DIRS = \ test/hs/Test/Ganeti/Hypervisor \ test/hs/Test/Ganeti/Hypervisor/Xen \ test/hs/Test/Ganeti/Locking \ + test/hs/Test/Ganeti/Objects \ test/hs/Test/Ganeti/Query \ test/hs/Test/Ganeti/THH \ test/hs/Test/Ganeti/Utils @@ -819,6 +820,7 @@ HS_LIB_SRCS = \ src/Ganeti/Monitoring/Server.hs \ src/Ganeti/Network.hs \ src/Ganeti/Objects.hs \ + src/Ganeti/Objects/BitArray.hs \ src/Ganeti/Objects/Lens.hs \ src/Ganeti/OpCodes.hs \ src/Ganeti/OpCodes/Lens.hs \ @@ -918,6 +920,7 @@ HS_TEST_SRCS = \ test/hs/Test/Ganeti/Locking/Waiting.hs \ test/hs/Test/Ganeti/Network.hs \ test/hs/Test/Ganeti/Objects.hs \ + test/hs/Test/Ganeti/Objects/BitArray.hs \ test/hs/Test/Ganeti/OpCodes.hs \ test/hs/Test/Ganeti/Query/Aliases.hs \ test/hs/Test/Ganeti/Query/Filter.hs \ diff --git a/src/Ganeti/Objects/BitArray.hs b/src/Ganeti/Objects/BitArray.hs new file mode 100644 index 0000000..4eceb7b --- /dev/null +++ b/src/Ganeti/Objects/BitArray.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BangPatterns, RankNTypes #-} + +{-| Space efficient bit arrays + +The module is meant to be imported qualified +(as it is common with collection libraries). + +-} + +{- + +Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. + +-} + +module Ganeti.Objects.BitArray + ( BitArray + , size + , empty + , zeroes + , count0 + , count1 + , foldr + , (!) + , setAt + , (-&-) + , (-|-) + , subset + , asString + , fromList + , toList + ) where + +import Prelude hiding (foldr) +import qualified Prelude as P + +import Control.Monad +import Control.Monad.Error +import qualified Data.IntSet as IS +import qualified Text.JSON as J + +import Ganeti.BasicTypes +import Ganeti.JSON + +-- | A fixed-size, space-efficient array of bits. +data BitArray = BitArray + { size :: !Int + , _bitArrayBits :: !IS.IntSet + -- ^ Must not contain elements outside [0..size-1]. + } + deriving (Eq, Ord) + +instance Show BitArray where + show = asString '0' '1' + +empty :: BitArray +empty = BitArray 0 IS.empty + +zeroes :: Int -> BitArray +zeroes s = BitArray s IS.empty + +-- | Right fold over the set, including indexes of each value. +foldr :: (Bool -> Int -> a -> a) -> a -> BitArray -> a +foldr f z (BitArray s bits) = let (j, x) = IS.foldr loop (s, z) bits + in feed0 (-1) j x + where + loop i (!l, x) = (i, f True i (feed0 i l x)) + feed0 !i !j x | i >= j' = x + | otherwise = feed0 i j' (f False j' x) + where j' = j - 1 + +-- | Converts a bit array into a string, given characters +-- for @0@ and @1@/ +asString :: Char -> Char -> BitArray -> String +asString c0 c1 = foldr f [] + where f b _ = ((if b then c1 else c0) :) + +-- | Computes the number of zeroes in the array. +count0 :: BitArray -> Int +count0 ba@(BitArray s _) = s - count1 ba + +-- | Computes the number of ones in the array. +count1 :: BitArray -> Int +count1 (BitArray _ bits) = IS.size bits + +infixl 9 ! +-- | Test a given bit in an array. +-- If it's outside its scope, it's always @False@. +(!) :: BitArray -> Int -> Bool +(!) (BitArray s bits) i | (i >= 0) && (i < s) = IS.member i bits + | otherwise = False + +-- | Sets or removes an element from a bit array. + +-- | Sets a given bit in an array. Fails if the index is out of bounds. +setAt :: (MonadError e m, Error e) => Int -> Bool -> BitArray -> m BitArray +setAt i False (BitArray s bits) = + return $ BitArray s (IS.delete i bits) +setAt i True (BitArray s bits) | (i >= 0) && (i < s) = + return $ BitArray s (IS.insert i bits) +setAt i True _ = failError $ "Index out of bounds: " ++ show i + +infixl 7 -&- +-- | An intersection of two bit arrays. +-- The length of the result is the minimum length of the two. +(-&-) :: BitArray -> BitArray -> BitArray +BitArray xs xb -&- BitArray ys yb = BitArray (min xs ys) + (xb `IS.intersection` yb) + +infixl 5 -|- +-- | A union of two bit arrays. +-- The length of the result is the maximum length of the two. +(-|-) :: BitArray -> BitArray -> BitArray +BitArray xs xb -|- BitArray ys yb = BitArray (max xs ys) (xb `IS.union` yb) + +-- | Checks if the first array is a subset of the other. +subset :: BitArray -> BitArray -> Bool +subset (BitArray _ xs) (BitArray _ ys) = IS.isSubsetOf xs ys + +-- | Converts a bit array into a list of booleans. +toList :: BitArray -> [Bool] +toList = foldr (\b _ -> (b :)) [] + +-- | Converts a list of booleans to a 'BitArray'. +fromList :: [Bool] -> BitArray +fromList xs = + -- Note: This traverses the list twice. It'd be better to compute everything + -- in one pass. + BitArray (length xs) (IS.fromList . map fst . filter snd . zip [0..] $ xs) + +instance J.JSON BitArray where + showJSON = J.JSString . J.toJSString . show + readJSON j = do + let parseBit '0' = return False + parseBit '1' = return True + parseBit c = fail $ "Neither '0' nor '1': '" ++ [c] ++ "'" + str <- readEitherString j + fromList `liftM` mapM parseBit str diff --git a/test/hs/Test/Ganeti/Objects/BitArray.hs b/test/hs/Test/Ganeti/Objects/BitArray.hs new file mode 100644 index 0000000..8cfa517 --- /dev/null +++ b/test/hs/Test/Ganeti/Objects/BitArray.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| Unittests for bit arrays + +-} + +{- + +Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. + +-} + +module Test.Ganeti.Objects.BitArray + ( testObjects_BitArray + , genBitArray + ) where + +import Test.QuickCheck + +import Control.Applicative +import Control.Monad + +import Test.Ganeti.TestHelper +import Test.Ganeti.TestCommon + +import Ganeti.Objects.BitArray as BA + +-- * Arbitrary instances + +instance Arbitrary BitArray where + arbitrary = fromList <$> arbitrary + +genBitArray :: Int -> Gen BitArray +genBitArray = liftA fromList . vector + +prop_BitArray_serialisation :: BitArray -> Property +prop_BitArray_serialisation = testSerialisation + +prop_BitArray_foldr :: [Bool] -> Property +prop_BitArray_foldr bs = + BA.foldr (((:) .) . (,)) [] (fromList bs) ==? zip bs [0..] + +prop_BitArray_fromToList :: BitArray -> Property +prop_BitArray_fromToList bs = + BA.fromList (BA.toList bs) ==? bs + +prop_BitArray_and :: [Bool] -> [Bool] -> Property +prop_BitArray_and xs ys = + (BA.fromList xs -&- BA.fromList ys) ==? BA.fromList (zipWith (&&) xs ys) + +prop_BitArray_or :: [Bool] -> [Bool] -> Property +prop_BitArray_or xs ys = + let xsl = length xs + ysl = length ys + l = max xsl ysl + comb = zipWith (||) (xs ++ replicate (l - xsl) False) + (ys ++ replicate (l - ysl) False) + in (BA.fromList xs -|- BA.fromList ys) ==? BA.fromList comb + +-- | Check that the counts of 1 bits holds. +prop_BitArray_counts :: Property +prop_BitArray_counts = do + n <- choose (0, 3) + ones <- replicateM n (lst True) + zrs <- replicateM n (lst False) + start <- lst False + let count = sum . map length $ ones + bs = start ++ concat (zipWith (++) ones zrs) + count1 (BA.fromList bs) ==? count + where + lst x = (`replicate` x) `liftM` choose (0, 2) + +-- | Check that the counts of free and occupied bits add up. +prop_BitArray_countsSum :: BitArray -> Property +prop_BitArray_countsSum a = + count0 a + count1 a ==? size a + +testSuite "Objects_BitArray" + [ 'prop_BitArray_serialisation + , 'prop_BitArray_foldr + , 'prop_BitArray_fromToList + , 'prop_BitArray_and + , 'prop_BitArray_or + , 'prop_BitArray_counts + , 'prop_BitArray_countsSum + ] diff --git a/test/hs/htest.hs b/test/hs/htest.hs index f47a7e2..a50ca98 100644 --- a/test/hs/htest.hs +++ b/test/hs/htest.hs @@ -62,6 +62,7 @@ import Test.Ganeti.Locking.Waiting import Test.Ganeti.Luxi import Test.Ganeti.Network import Test.Ganeti.Objects +import Test.Ganeti.Objects.BitArray import Test.Ganeti.OpCodes import Test.Ganeti.Query.Aliases import Test.Ganeti.Query.Filter @@ -131,6 +132,7 @@ allTests = , testLuxi , testNetwork , testObjects + , testObjects_BitArray , testOpCodes , testQuery_Aliases , testQuery_Filter -- 2.0.0.526.g5318336
