diff --git a/hw-prim.cabal b/hw-prim.cabal --- a/hw-prim.cabal +++ b/hw-prim.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b4513a18c623ca2703a2c1fc185d0b0ff8165c970ded30e2cf582ae54be58819 +-- hash: 3da5a5c4ec15aafba41e3a027d8092886e0bca1ad4a9bcb85767e43bf4684b59 name: hw-prim -version: 0.6.1.0 +version: 0.6.2.0 synopsis: Primitive functions and data types description: Please see README.md category: Data diff --git a/src/HaskellWorks/Data/Vector/AsVector64.hs b/src/HaskellWorks/Data/Vector/AsVector64.hs --- a/src/HaskellWorks/Data/Vector/AsVector64.hs +++ b/src/HaskellWorks/Data/Vector/AsVector64.hs @@ -3,8 +3,10 @@ ( AsVector64(..) ) where +import Data.Bits import Data.Word +import qualified Data.ByteString as BS import qualified Data.Vector.Storable as DVS class AsVector64 a where @@ -12,3 +14,42 @@ instance AsVector64 (DVS.Vector Word64) where asVector64 = id + +instance AsVector64 BS.ByteString where + asVector64 bs = DVS.constructN ((BS.length bs + 7) `div` 8) go + where go :: DVS.Vector Word64 -> Word64 + go u = let bsi = DVS.length u * 8 in + if bsi + 8 <= BS.length bs + then let w0 = fromIntegral $ BS.index bs (bsi + 0) + w1 = fromIntegral $ BS.index bs (bsi + 1) + w2 = fromIntegral $ BS.index bs (bsi + 2) + w3 = fromIntegral $ BS.index bs (bsi + 3) + w4 = fromIntegral $ BS.index bs (bsi + 4) + w5 = fromIntegral $ BS.index bs (bsi + 5) + w6 = fromIntegral $ BS.index bs (bsi + 6) + w7 = fromIntegral $ BS.index bs (bsi + 7) + in (w0 `shiftL` 0) .|. + (w1 `shiftL` 8) .|. + (w2 `shiftL` 16) .|. + (w3 `shiftL` 24) .|. + (w4 `shiftL` 32) .|. + (w5 `shiftL` 40) .|. + (w6 `shiftL` 48) .|. + (w7 `shiftL` 56) + else let w0 = let i = bsi + 0 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 0) else 0 + w1 = let i = bsi + 1 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 1) else 0 + w2 = let i = bsi + 2 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 2) else 0 + w3 = let i = bsi + 3 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 3) else 0 + w4 = let i = bsi + 4 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 4) else 0 + w5 = let i = bsi + 5 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 5) else 0 + w6 = let i = bsi + 6 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 6) else 0 + w7 = let i = bsi + 7 in if i < BS.length bs then fromIntegral $ BS.index bs (bsi + 7) else 0 + in (w0 `shiftL` 0) .|. + (w1 `shiftL` 8) .|. + (w2 `shiftL` 16) .|. + (w3 `shiftL` 24) .|. + (w4 `shiftL` 32) .|. + (w5 `shiftL` 40) .|. + (w6 `shiftL` 48) .|. + (w7 `shiftL` 56) + diff --git a/src/HaskellWorks/Data/Vector/AsVector64s.hs b/src/HaskellWorks/Data/Vector/AsVector64s.hs --- a/src/HaskellWorks/Data/Vector/AsVector64s.hs +++ b/src/HaskellWorks/Data/Vector/AsVector64s.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module HaskellWorks.Data.Vector.AsVector64s ( AsVector64s(..) @@ -29,35 +32,34 @@ {-# INLINE asVector64s #-} bytestringsToVectors :: Int -> [BS.ByteString] -> [DVS.Vector Word64] -bytestringsToVectors n bss = DVS.createT $ go (byteStringToVector8 <$> bss) - where go :: [DVSM.MVector s Word8] -> ST s [DVSM.MVector s Word64] - go ts = do - result <- buildOneVector n ts - case result of - Just (us, v) -> (v:) <$> go us - Nothing -> return [] +bytestringsToVectors n bss = go bss + where go :: [BS.ByteString] -> [DVS.Vector Word64] + go bs = case DVS.createT (buildOneVector n bs) of + (cs, ws) -> if DVS.length ws > 0 + then ws:go cs + else [] {-# INLINE bytestringsToVectors #-} -buildOneVector :: forall s. Int -> [DVSM.MVector s Word8] -> ST s (Maybe ([DVSM.MVector s Word8], DVSM.MVector s Word64)) -buildOneVector n ss = case dropWhile ((== 0) . DVSM.length) ss of - [] -> return Nothing +buildOneVector :: forall s. Int -> [BS.ByteString] -> ST s ([BS.ByteString], DVS.MVector s Word64) +buildOneVector n ss = case dropWhile ((== 0) . BS.length) ss of + [] -> ([],) <$> DVSM.new 0 cs -> do v64 <- DVSM.unsafeNew n let v8 = DVSM.unsafeCast v64 rs <- go cs v8 - return (Just (rs, v64)) - where go :: [DVSM.MVector s Word8] -> DVSM.MVector s Word8 -> ST s [DVSM.MVector s Word8] + return (rs, v64) + where go :: [BS.ByteString] -> DVSM.MVector s Word8 -> ST s [BS.ByteString] go ts v = if DVSM.length v > 0 then case ts of (u:us) -> do - if DVSM.length u <= DVSM.length v - then case DVSM.splitAt (DVSM.length u) v of + if BS.length u <= DVSM.length v + then case DVSM.splitAt (BS.length u) v of (va, vb) -> do - DVSM.copy va u + DVSM.copy va (byteStringToVector8 u) go us vb - else case DVSM.splitAt (DVSM.length v) u of + else case BS.splitAt (DVSM.length v) u of (ua, ub) -> do - DVSM.copy v ua + DVSM.copy v (byteStringToVector8 ua) return (ub:us) [] -> do DVSM.set v 0 diff --git a/test/HaskellWorks/Data/Vector/AsVector64sSpec.hs b/test/HaskellWorks/Data/Vector/AsVector64sSpec.hs --- a/test/HaskellWorks/Data/Vector/AsVector64sSpec.hs +++ b/test/HaskellWorks/Data/Vector/AsVector64sSpec.hs @@ -6,6 +6,7 @@ ( spec ) where +import HaskellWorks.Data.Vector.AsVector64 import HaskellWorks.Data.Vector.AsVector64s import HaskellWorks.Hspec.Hedgehog import Hedgehog @@ -20,7 +21,7 @@ spec :: Spec spec = describe "HaskellWorks.Data.Vector.AsVector64sSpec" $ do - it "Conversion of ByteString works" $ requireProperty $ do + it "Conversion of ByteString works 1" $ requireProperty $ do bss <- forAll $ (BS.pack <$>) <$> G.list (R.linear 0 8) (G.list (R.linear 0 24) (G.word8 R.constantBounded)) mconcat (asVector64s 1 [mconcat bss]) === mconcat (asVector64s 1 bss) True === True @@ -30,3 +31,10 @@ let expected = mconcat (asVector64s 1 bss) (reverse . dropWhile (== 0) . reverse) (DVS.toList actual) === (reverse . dropWhile (== 0) . reverse) (DVS.toList expected) True === True + it "Conversion of ByteString works 3" $ requireProperty $ do + bss <- forAll $ (BS.pack <$>) <$> G.list (R.linear 0 8) (G.list (R.linear 0 24) (G.word8 R.constantBounded)) + let actual = mconcat (asVector64s 1 bss) + let expected = asVector64 (mconcat bss) + (reverse . dropWhile (== 0) . reverse) (DVS.toList actual) === (reverse . dropWhile (== 0) . reverse) (DVS.toList expected) + True === True +