byte-containers (empty) → 0.1.0.0
raw patch · 7 files changed
+435/−0 lines, 7 filesdep +basedep +byte-containersdep +byteslicesetup-changed
Dependencies added: base, byte-containers, byteslice, primitive, quickcheck-classes, run-st, tasty, tasty-quickcheck, wide-word
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +3/−0
- byte-containers.cabal +63/−0
- src/Data/Map/Word8.hs +212/−0
- src/Data/Set/Word8.hs +46/−0
- test/Main.hs +76/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for byte-containers++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrew Martin nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ byte-containers.cabal view
@@ -0,0 +1,63 @@+cabal-version: 2.2+name: byte-containers+version: 0.1.0.0+synopsis: Sets and maps with 8-bit words for keys+description:+ This library provides variant of @Data.Map@ and @Data.Set@ from+ the @containers@ library where the key is specialized to @Word8@.+ Internally, this uses a 256-bit bitmask for the presence of keys+ and a @SmallArray@ of values of keys that were present. For example,+ the map @{2 => Z, 3 => B, 5 => X, 9 => A}@ would be repsented in+ memory as:+ .+ > Bitmask: 0011010001000000... (240 more zero bits)+ > Value Array: Z,B,X,A+ .+ This is optimized for reads. Lookup is @O(1)@. Union is technically+ @O(1)@ but only because the universe of keys is finite. The current+ implementation always scans through all 256 bits of key space.++homepage: https://github.com/byteverse/byte-containers+bug-reports: https://github.com/byteverse/byte-containers/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: amartin@layer3com.com+copyright: 2020 Andrew Martin+category: Data+build-type: Simple+extra-doc-files: CHANGELOG.md++library+ build-depends:+ , base >=4.12 && <5+ , primitive >=0.7 && <0.10+ , run-st >=0.1 && <0.2+ , wide-word >=0.1.1 && <0.2++ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Data.Map.Word8+ Data.Set.Word8++ ghc-options: -Wall -O2++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -Wall -O2+ build-depends:+ , base >=4.12 && <5+ , byte-containers+ , byteslice >=0.2.9 && <0.3+ , primitive >=0.7 && <0.10+ , quickcheck-classes >=0.6.4+ , tasty+ , tasty-quickcheck++source-repository head+ type: git+ location: git://github.com/byteverse/byte-containers.git
+ src/Data/Map/Word8.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++module Data.Map.Word8+ ( Map+ , lookup+ , null+ , size+ , empty+ , singleton+ , union+ , unionWith+ , insert+ , insertWith+ , foldrWithKeys+ , foldl'+ , traverse_+ , toList+ , fromList+ ) where++import Prelude hiding (lookup, null)++import Control.Monad.ST.Run (runSmallArrayST)+import Data.Bits (bit, popCount, testBit, unsafeShiftR, (.&.), (.|.))+import Data.Primitive (SmallArray)+import Data.WideWord (Word256)+import Data.Word (Word8)++import qualified Data.Foldable as F+import qualified Data.Primitive as PM++-- | A map whose keys are 8-bit words.+data Map a+ = Map+ -- Invariant: len(values) = popcnt keys+ {-# UNPACK #-} !Word256+ {-# UNPACK #-} !(SmallArray a)++deriving stock instance (Eq a) => Eq (Map a)+deriving stock instance Functor Map++instance (Show a) => Show (Map a) where+ showsPrec p m = showsPrec p (toList m)++instance (Semigroup a) => Semigroup (Map a) where+ (<>) = unionWith (<>)++instance (Semigroup a) => Monoid (Map a) where+ mempty = empty++singleton :: Word8 -> a -> Map a+singleton !k v =+ Map+ (bit (fromIntegral @Word8 @Int k))+ (runSmallArrayST (PM.newSmallArray 1 v >>= PM.unsafeFreezeSmallArray))++-- | Is the passed map empty?+null :: Map a -> Bool+null m = size m == 0++-- | The number of elements the passed map contains.+size :: Map a -> Int+size (Map keys _) = popCount keys++-- | The empty map.+empty :: Map a+empty = Map 0 mempty++-- | Lookup the value at a key in the map.+lookup :: Word8 -> Map a -> Maybe a+lookup kw (Map keys vals) = case testBit keys k of+ False -> Nothing+ True -> case k of+ 0 -> Just (PM.indexSmallArray vals 0)+ _ ->+ let ix = popCount (unsafeShiftR maxBound (256 - k) .&. keys)+ in Just (PM.indexSmallArray vals ix)+ where+ k = fromIntegral @Word8 @Int kw++{- | The expression @'union' t1 t2@ takes the left-biased union+of @t1@ and @t2@. It prefers @t1@ when duplicate keys are+encountered (i.e. @'union' == 'unionWith' const@).+-}+union :: Map a -> Map a -> Map a+union !ma@(Map ksA vsA) !mb@(Map ksB vsB)+ | ksA == 0 = mb+ | ksB == 0 = ma+ | otherwise = Map ks $ runSmallArrayST do+ let sz = popCount ks+ dst <- PM.newSmallArray sz =<< PM.indexSmallArrayM vsA 0+ foldlZipBits256+ ( \(!ix, !ixA, !ixB) a b -> case a of+ True -> do+ PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsA ixA+ pure (ix + 1, ixA + 1, if b then ixB + 1 else ixB)+ False -> case b of+ True -> do+ PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsB ixB+ pure (ix + 1, ixA, ixB + 1)+ False -> pure (ix, ixA, ixB)+ )+ (0, 0, 0)+ ksA+ ksB+ PM.unsafeFreezeSmallArray dst+ where+ ks = ksA .|. ksB++-- | Union with a combining function.+unionWith :: (a -> a -> a) -> Map a -> Map a -> Map a+unionWith g !ma@(Map ksA vsA) !mb@(Map ksB vsB)+ | ksA == 0 = mb+ | ksB == 0 = ma+ | otherwise = Map ks $ runSmallArrayST do+ let sz = popCount ks+ dst <- PM.newSmallArray sz =<< PM.indexSmallArrayM vsA 0+ foldlZipBits256+ ( \(!ix, !ixA, !ixB) a b -> case a of+ True -> case b of+ True -> do+ a <- PM.indexSmallArrayM vsA ixA+ b <- PM.indexSmallArrayM vsB ixB+ let !c = g a b+ PM.writeSmallArray dst ix c+ pure (ix + 1, ixA + 1, ixB + 1)+ False -> do+ PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsA ixA+ pure (ix + 1, ixA + 1, ixB)+ False -> case b of+ True -> do+ PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsB ixB+ pure (ix + 1, ixA, ixB + 1)+ False -> pure (ix, ixA, ixB)+ )+ (0, 0, 0)+ ksA+ ksB+ PM.unsafeFreezeSmallArray dst+ where+ ks = ksA .|. ksB++insert :: Word8 -> a -> Map a -> Map a+insert = insertWith const++{- | Insert with a function, combining new value and old value.+@'insertWith' f key value mp@ will insert the pair @(key, value)@ into @mp@+if @key@ does not exist in the map.+If the key does exist, the function will insert the pair+@(key, f new_value old_value)@.+-}+insertWith :: (a -> a -> a) -> Word8 -> a -> Map a -> Map a+insertWith f k v m = unionWith f (singleton k v) m++-- Internal function. This is strict in the accumulator.+foldlZipBits256 ::+ (Monad m) =>+ (a -> Bool -> Bool -> m a) ->+ a ->+ Word256 ->+ Word256 ->+ m ()+foldlZipBits256 g !a0 !x !y = go 0 a0+ where+ go !ix !a = case ix of+ 256 -> pure ()+ _ -> do+ let xval = testBit x ix+ let yval = testBit y ix+ a' <- g a xval yval+ go (ix + 1) a'++foldrBits256 :: (Word8 -> b -> b) -> b -> Word256 -> b+foldrBits256 g b0 w = go 0+ where+ go ix = case ix of+ 256 -> b0+ _ -> case testBit w ix of+ True -> g (fromIntegral @Int @Word8 ix) (go (ix + 1))+ False -> go (ix + 1)++foldrWithKeys :: (Word8 -> a -> b -> b) -> b -> Map a -> b+foldrWithKeys g b0 (Map ks vs) = go 0 0+ where+ go !ix !ixVal = case ix of+ 256 -> b0+ _ -> case testBit ks ix of+ True ->+ g+ (fromIntegral @Int @Word8 ix)+ (PM.indexSmallArray vs ixVal)+ (go (ix + 1) (ixVal + 1))+ False -> go (ix + 1) ixVal++foldl' :: (b -> a -> b) -> b -> Map a -> b+{-# INLINE foldl' #-}+foldl' f b0 (Map _ vs) = F.foldl' f b0 vs++traverse_ :: (Applicative m) => (a -> m b) -> Map a -> m ()+{-# INLINE traverse_ #-}+traverse_ f (Map _ vs) = F.traverse_ f vs++toList :: Map a -> [(Word8, a)]+toList = foldrWithKeys (\k v b -> (k, v) : b) []++fromList :: [(Word8, a)] -> Map a+fromList = F.foldl' (\acc (k, v) -> union acc (singleton k v)) empty
+ src/Data/Set/Word8.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}++module Data.Set.Word8+ ( Set+ , member+ , null+ , size+ , empty+ , singleton+ , union+ , insert+ ) where++import Prelude hiding (lookup, null)++import Data.Bits (bit, popCount, testBit, (.|.))+import Data.WideWord (Word256)+import Data.Word (Word8)++-- | A map whose keys are 8-bit words.+newtype Set = Set Word256++-- | Is the passed map empty?+null :: Set -> Bool+null m = size m == 0++-- | The number of elements the passed map contains.+size :: Set -> Int+size (Set keys) = popCount keys++empty :: Set+empty = Set 0++singleton :: Word8 -> Set+singleton !k = Set (bit (fromIntegral @Word8 @Int k))++member :: Word8 -> Set -> Bool+member k (Set keys) =+ testBit keys (fromIntegral @Word8 @Int k)++union :: Set -> Set -> Set+union (Set x) (Set y) = Set (x .|. y)++insert :: Word8 -> Set -> Set+insert k s = union (singleton k) s
+ test/Main.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Data.Map.Word8 (Map)+import Data.Proxy (Proxy (..))+import Data.Semigroup (Sum)+import Data.Word (Word8)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.QuickCheck (Arbitrary, Discard (Discard), property, testProperty, (===))++import qualified Data.List as List+import qualified Data.Map.Word8 as Map+import qualified Test.QuickCheck.Classes as QCC+import qualified Test.Tasty.QuickCheck as TQC++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup+ "byte-containers"+ [ testGroup+ "append"+ [ testProperty "doubleton" $ \ka (va :: Word) kb vb ->+ Map.toList+ (Map.union (Map.singleton ka va) (Map.singleton kb vb))+ === ( case compare ka kb of+ EQ -> [(ka, va)]+ LT -> [(ka, va), (kb, vb)]+ GT -> [(kb, vb), (ka, va)]+ )+ , testProperty "lookup" lookupProp+ , testProperty "associative" $ \alist blist clist ->+ let a = Map.fromList alist :: Map Word+ b = Map.fromList blist+ c = Map.fromList clist+ in Map.union a (Map.union b c)+ === Map.union (Map.union a b) c+ , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Map [Integer])))+ , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Map [Integer])))+ , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (Map (Sum Integer))))+ , lawsToTest (QCC.functorLaws (Proxy :: Proxy Map))+ ]+ , testGroup+ "insert"+ [ testProperty "replaces" $ \k v v' alist ->+ let a = Map.insert k v (Map.fromList alist) :: Map Word+ a' = Map.insert k v' a+ in if+ | v /= v' ->+ Map.lookup k a' === Just v'+ | otherwise -> property Discard+ ]+ ]++instance (Arbitrary a) => Arbitrary (Map a) where+ arbitrary = Map.fromList <$> TQC.arbitrary++lookupProp :: TQC.Property+lookupProp = TQC.property $ \(xs :: [(Word8, Integer)]) ->+ let ys = Map.fromList xs+ in foldr+ ( \x r -> case List.lookup x xs == Map.lookup x ys of+ True -> r+ False -> TQC.counterexample ("key " ++ show x) False+ )+ (TQC.property True)+ [0 .. 255 :: Word8]++lawsToTest :: QCC.Laws -> TestTree+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)