packages feed

bitarray-bs (empty) → 0.1.0.0

raw patch · 9 files changed

+540/−0 lines, 9 filesdep +basedep +bitarray-bsdep +bytestringsetup-changed

Dependencies added: base, bitarray-bs, bytestring

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `bitarray-bs`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  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.++3.  Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,4 @@+# bitarray-bs++Bit array based on ByteString.+This package used by package yaftee-conduit-bytestring.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bitarray-bs.cabal view
@@ -0,0 +1,60 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           bitarray-bs+version:        0.1.0.0+synopsis:       Bit array based on ByteString+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/bitarray-bs#readme>+category:       Data+homepage:       https://github.com/YoshikuniJujo/bitarray-bs#readme+bug-reports:    https://github.com/YoshikuniJujo/bitarray-bs/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      (c) 2025 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/bitarray-bs++library+  exposed-modules:+      Data.ByteString.Bit+      Data.ByteString.BitArray+      Data.ByteString.Lazy.BitArray+  other-modules:+      Paths_bitarray_bs+  autogen-modules:+      Paths_bitarray_bs+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.12.*+  default-language: Haskell2010++test-suite bitarray-bs-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_bitarray_bs+  autogen-modules:+      Paths_bitarray_bs+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bitarray-bs+    , bytestring ==0.12.*+  default-language: Haskell2010
+ src/Data/ByteString/Bit.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.ByteString.Bit (++	-- * BIT++	B(..), bit,++	-- * LIST++	listToNum, listFromNum,++	-- * QUEUE++	Queue, empty, append, uncons, popByte++	) where++import Control.Arrow+import Data.Bits hiding (bit)+import Data.Bool+import Data.Word++data B = O | I deriving (Show, Eq, Ord)++bit :: a -> a -> B -> a+bit x y = \case O -> x; I -> y++listToNum :: Bits n => [B] -> n+listToNum = foldr (\b s -> bit id (`setBit` 0) b $ s `shiftL` 1) zeroBits++listFromNum :: Bits n => Int -> n -> [B]+listFromNum ln n = bool O I . (n `testBit`) <$> [0 .. ln - 1]++type Queue = ([B], [B])++empty :: Queue+empty = ([], [])++append :: Queue -> [B] -> Queue+append (xs, ys) bs = (xs, reverse bs ++ ys)++uncons :: Queue -> Maybe (B, Queue)+uncons = \case+	([], []) -> Nothing+	([], ys) -> uncons (reverse ys, [])+	(x : xs, ys) -> Just (x, (xs, ys))++popByte :: Queue -> Maybe (Word8, Queue)+popByte = ((listToNum `first`) <$>) . unfoldrN 8 uncons++unfoldrN :: Int -> (a -> Maybe (b, a)) -> a -> Maybe ([b], a)+unfoldrN 0 _ x = Just ([], x)+unfoldrN n f x = case f x of+	Nothing -> Nothing+	Just (y, x') -> ((y :) `first`) <$> unfoldrN (n - 1) f x'
+ src/Data/ByteString/BitArray.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.ByteString.BitArray (++	-- * BIT ARRAY++	B, null, length, empty,++	-- * FROM/TO BYTE STRING++	fromByteString, toByteString,++	-- * APPEND++	append, appendByteString,++	-- * SPLIT++	pop, popBits, splitAt, byteBoundary,++	-- * CONVERT++	toBits, toBits'++	) where++import Prelude hiding (null, length, splitAt)+import Control.Arrow+import Data.Bits+import Data.Bool+import Data.ByteString qualified as BS+import Data.ByteString.Bit qualified as Bit++data B = B { unB :: [B1] } deriving Show++empty :: B+empty = B []++null :: B -> Bool+null = \case (B []) -> True; _ -> False++length :: B -> Int+length  = sum . (length1 <$>) . unB++data B1 = B1 { zero :: Int, length1 :: Int, body :: BS.ByteString }+	deriving Show++empty1 :: B1+empty1 = B1 { zero = 0, length1 = 0, body = "" }++null1 :: B1 -> Bool+null1 = \case B1 { length1 = 0 } -> True; _ -> False++fromByteString :: BS.ByteString -> B+fromByteString "" = B []+fromByteString bs = B [B1 { zero = 0, length1 = 8 * BS.length bs, body = bs }]++toByteString :: B -> Either B BS.ByteString+toByteString b@(B b1s) = case b1s of+	[] -> Right ""+	[b1] -> either (Left . B . (: [])) Right $ toByteString1 b1+	_ -> Left b++toByteString1 :: B1 -> Either B1 BS.ByteString+toByteString1 ba@B1 { zero = z, length1 = ln, body = bs } =+	case (z, ln `mod` 8) of (0, 0) -> Right bs; _ -> Left ba++append :: B -> B -> B+B b1 `append` B b2 = B . normalize $ b1 ++ b2++appendByteString :: B -> BS.ByteString -> B+appendByteString b = append b . fromByteString++normalize :: [B1] -> [B1]+normalize = go empty1 . (normalize1 <$>)+	where+	go B1 { length1 = 0 } = \case+		[] -> []+		b1' : b1s -> go b1' b1s+	go b1@B1 { zero = z1, length1 = ln1, body = bs1 } = \case+		[]	| ln1 > 0 -> [b1]+			| otherwise -> []+		B1 { length1 = 0 } : b1s -> go b1 b1s+		b1'@B1 { zero = z2, length1 = ln2, body = bs2 } : b1s+			| (z1 + ln1) `mod` 8 == 0, z2 == 0 ->+				go B1 {	zero = z1, length1 = ln1 + ln2,+					body = bs1 `BS.append` bs2 } b1s+			| (z1 + ln1 - z2) `mod` 8 == 0 ->+				go B1 { zero = z1, length1 = ln1 + ln2,+					body = BS.init bs1 `BS.append` (+						(	BS.last bs1 .&. bitMask 0 (z2 - 1) .|.+							BS.head bs2 .&. bitMask z2 7) `BS.cons`+						BS.tail bs2 ) } b1s+			| otherwise -> b1 : go b1' b1s++bitMask :: Bits n => Int -> Int -> n+bitMask i j = foldl setBit zeroBits [i .. j]++normalize1 :: B1 -> B1+normalize1 B1 { zero = z, length1 = ln, body = bs }+	| 0 <= z = B1 {+		zero = z',+		length1 = ln, body = BS.take t $ BS.drop (z `div` 8) bs }+	| otherwise = error "normalize: bad"+	where z' = z `mod` 8; t = (ln + z' - 1) `div` 8 + 1++pop :: B -> Maybe (Bit.B, B)+pop (B []) = Nothing+pop (B (b1 : b1s)) = case pop1 b1 of+	Nothing -> error $ "never occur: " ++ show b1 ++ " " ++ show b1s+	Just (b, b1') -> Just (b, B . normalize $ b1' : b1s )++pop1 :: B1 -> Maybe (Bit.B, B1)+pop1 B1 { zero = z, length1 = ln, body = bs } = case (z, ln) of+	(_, 0) -> Nothing+	(7, _) -> case BS.uncons bs of+		Just (b, bs') -> Just (+			bool Bit.O Bit.I (b `testBit` 7),+			B1 { zero = 0, length1 = ln - 1, body = bs' } )+		Nothing -> error "never occur"+	_ -> Just (+		bool Bit.O Bit.I $ BS.head bs `testBit` z,+		B1 { zero = z + 1, length1 = ln - 1, body = bs } )++splitAt :: Int -> B -> Maybe (B, B)+splitAt n0 = ((B *** B) <$>) . go n0 . unB+	where+	go 0 b1s = Just ([], b1s)+	go _ [] = Nothing+	go n (b1@B1 { length1 = ln } : b1s)+		| n < ln = case splitAt1 n b1 of+			Nothing -> error "never occur"+			Just (b1t, b1d) -> Just ([b1t], b1d : b1s)+		| n == ln = Just ([b1], b1s)+		| otherwise = ((b1 :) `first`) <$> go (n - ln) b1s++splitAt1 :: Int -> B1 -> Maybe (B1, B1)+splitAt1 n B1 { zero = z, length1 = ln, body = bs }+	| ln < n = Nothing+	| otherwise = Just (+		normalize1 B1 { zero = z, length1 = n, body = bs },+		normalize1 B1 { zero = z + n, length1 = ln - n, body = bs } )++byteBoundary :: B -> Either (B, B) B+byteBoundary (B b) = case go b of+	([], b2) -> Right $ B b2; b12 -> Left $ (B *** B) b12+	where+	go [] = ([], [])+	go (b1 : b1s) = case byteBoundary1 b1 of+		Nothing -> (b1 :) `first` go b1s+		Just (b1t, b1d)+			| null1 b1t -> ([], b1d : b1s)+			| otherwise -> ([b1t], b1d : b1s)++byteBoundary1 :: B1 -> Maybe (B1, B1)+byteBoundary1 b1@B1 { zero = z, length1 = ln, body = bs } = case z of+	0 -> Just (empty1, b1)+	_	| z + ln <= 8 -> Nothing+		| otherwise -> Just (+			B1 { zero = z, length1 = 8 - z, body = BS.take 1 bs },+			B1 { zero = 0, length1 = ln - 8 + z, body = BS.tail bs } )++popBits :: Bits n => Int -> B -> Maybe (n, B)+popBits ln b0+	| length b0 < ln = Nothing+	| otherwise = Just $ go 0 ln b0+	where+	go i j b = case (j, pop b) of+		(0, _) -> (zeroBits, b)+		(_, Nothing) -> error "never occur"+		(_, Just (bt, bts)) -> Bit.bit id (`setBit` i) bt `first` go (i + 1) (j - 1) bts++toBits :: Bits n => B -> n+toBits = go zeroBits+	where go i b = case pop b of+		Nothing -> zeroBits+		Just (bt, bts) -> Bit.bit id (`setBit` i) bt $ go (i + 1) bts++toBits' :: forall n . FiniteBits n => B -> Maybe n+toBits' b0+	| length b0 <= finiteBitSize (undefined :: n) = Just $ go 0 b0+	| otherwise = Nothing+	where go i b = case pop b of+		Nothing -> zeroBits+		Just (bt, bts) -> Bit.bit id (`setBit` i) bt $ go (i + 1) bts
+ src/Data/ByteString/Lazy/BitArray.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.ByteString.Lazy.BitArray (++	-- * BIT ARRAY++	B, null, length, empty,++	-- * FROM/TO LAZY BYTE STRING++	fromByteString, toByteString,++	-- * APPEND++	append, appendByteString,++	-- * SPLIT++	pop, popBits, splitAt, byteBoundary,++	-- * CONVERT++	toBits, toBits'++	) where++import Prelude hiding (null, length, splitAt)+import Control.Arrow+import Data.Bits+import Data.Bool+import Data.Int+import Data.ByteString.Lazy qualified as LBS+import Data.ByteString.Bit qualified as Bit++data B = B { unB :: [B1] } deriving Show++empty :: B+empty = B []++null :: B -> Bool+null = \case (B []) -> True; _ -> False++length :: B -> Int64+length = sum . (length1 <$>) . unB++data B1 = B1 { zero :: Int64, length1 :: Int64, body :: LBS.ByteString }+	deriving Show++empty1 :: B1+empty1 = B1 { zero = 0, length1 = 0, body = "" }++null1 :: B1 -> Bool+null1 = \case B1 { length1 = 0 } -> True; _ -> False++fromByteString :: LBS.ByteString -> B+fromByteString "" = B []+fromByteString bs = B [B1 { zero = 0, length1 = 8 * LBS.length bs, body = bs }]++toByteString :: B -> Either B LBS.ByteString+toByteString b@(B b1s) = case b1s of+	[] -> Right ""+	[b1] -> either (Left . B . (: [])) Right $ toByteString1 b1+	_ -> Left b++toByteString1 :: B1 -> Either B1 LBS.ByteString+toByteString1 ba@B1 { zero = z, length1 = ln, body = bs } =+	case (z, ln `mod` 8) of (0, 0) -> Right bs; _ -> Left ba++append :: B -> B -> B+B b1 `append` B b2 = B . normalize $ b1 ++ b2++appendByteString :: B -> LBS.ByteString -> B+appendByteString b = append b . fromByteString++normalize :: [B1] -> [B1]+normalize = go empty1 . (normalize1 <$>)+	where+	go B1 { length1 = 0 } = \case+		[] -> []+		b1' : b1s -> go b1' b1s+	go b1@B1 { zero = z1, length1 = ln1, body = bs1 } = \case+		[]	| ln1 > 0 -> [b1]+			| otherwise -> []+		B1 { length1 = 0 } : b1s -> go b1 b1s+		b1'@B1 { zero = z2, length1 = ln2, body = bs2 } : b1s+			| (z1 + ln1) `mod` 8 == 0, z2 == 0 ->+				go B1 {	zero = z1, length1 = ln1 + ln2,+					body = bs1 `LBS.append` bs2 } b1s+			| (z1 + ln1 - z2) `mod` 8 == 0 ->+				go B1 {	zero = z1, length1 = ln1 + ln2,+					body = LBS.init bs1 `LBS.append` (+						(	LBS.last bs1 .&. bitMask 0 (z2 - 1) .|.+							LBS.head bs2 .&. bitMask z2 7) `LBS.cons`+						LBS.tail bs2 ) } b1s+			| otherwise -> b1 : go b1' b1s++bitMask :: Bits n => Int64 -> Int64 -> n+bitMask i j = foldl setBit zeroBits $ fromIntegral <$> [i .. j]++normalize1 :: B1 -> B1+normalize1 B1 { zero = z, length1 = ln, body = bs }+	| 0 <= z = B1 {+		zero = z',+		length1 = ln, body = LBS.take t $ LBS.drop (z `div` 8) bs }+	| otherwise = error "normalize: bad"+	where z' = z `mod` 8; t = (ln + z' - 1) `div` 8 + 1++pop :: B -> Maybe (Bit.B, B)+pop (B []) = Nothing+pop (B (b1 : b1s)) = case pop1 b1 of+	Nothing -> error $ "never occur: " ++ show b1 ++ " " ++ show b1s+	Just (b, b1') -> Just (b, B . normalize $ b1' : b1s )++pop1 :: B1 -> Maybe (Bit.B, B1)+pop1 B1 { zero = z, length1 = ln, body = bs } = case (z, ln) of+	(_, 0) -> Nothing+	(7, _) -> case LBS.uncons bs of+		Just (b, bs') -> Just (+			bool Bit.O Bit.I (b `testBit` 7),+			B1 { zero = 0, length1 = ln - 1, body = bs' } )+		Nothing -> error "never occur"+	_ -> Just (+		bool Bit.O Bit.I $ LBS.head bs `testBit` fromIntegral z,+		B1 { zero = z + 1, length1 = ln - 1, body = bs } )++splitAt :: Int64 -> B -> Maybe (B, B)+splitAt n0 = ((B *** B) <$>) . go n0 . unB+	where+	go 0 b1s = Just ([], b1s)+	go _ [] = Nothing+	go n (b1@B1 { length1 = ln } : b1s)+		| n < ln = case splitAt1 n b1 of+			Nothing -> error "never occur"+			Just (b1t, b1d) -> Just ([b1t], b1d : b1s)+		| n == ln = Just ([b1], b1s)+		| otherwise = ((b1 :) `first`) <$> go (n - ln) b1s++splitAt1 :: Int64 -> B1 -> Maybe (B1, B1)+splitAt1 n B1 { zero = z, length1 = ln, body = bs }+	| ln < n = Nothing+	| otherwise = Just (+		normalize1 B1 { zero = z, length1 = n, body = bs },+		normalize1 B1 { zero = z + n, length1 = ln - n, body = bs } )++byteBoundary :: B -> Either (B, B) B+byteBoundary (B b) = case go b of+	([], b2) -> Right $ B b2; b12 -> Left $ (B *** B) b12+	where+	go [] = ([], [])+	go (b1 : b1s) = case byteBoundary1 b1 of+		Nothing -> (b1 :) `first` go b1s+		Just (b1t, b1d)+			| null1 b1t -> ([], b1d : b1s)+			| otherwise -> ([b1t], b1d : b1s)++byteBoundary1 :: B1 -> Maybe (B1, B1)+byteBoundary1 b1@B1 { zero = z, length1 = ln, body = bs } = case z of+	0 -> Just (empty1, b1)+	_	| z + ln <= 8 -> Nothing+		| otherwise -> Just (+			B1 { zero = z, length1 = 8 - z, body = LBS.take 1 bs },+			B1 { zero = 0, length1 = ln - 8 + z, body = LBS.tail bs } )++popBits :: Bits n => Int64 -> B -> Maybe (n, B)+popBits ln b0+	| length b0 < ln = Nothing+	| otherwise = Just $ go 0 ln b0+	where+	go i j b = case (j, pop b) of+		(0, _) -> (zeroBits, b)+		(_, Nothing) -> error "never occur"+		(_, Just (bt, bts)) -> Bit.bit id (`setBit` i) bt `first` go (i + 1) (j - 1) bts++toBits :: Bits n => B -> n+toBits = go zeroBits+	where go i b = case pop b of+		Nothing -> zeroBits+		Just (bt, bts) -> Bit.bit id (`setBit` i) bt $ go (i + 1) bts++toBits' :: forall n . FiniteBits n => B -> Maybe n+toBits' b0+	| length b0 <= fromIntegral (finiteBitSize (undefined :: n)) = Just $ go 0 b0+	| otherwise = Nothing+	where go i b = case pop b of+		Nothing -> zeroBits+		Just (bt, bts) -> Bit.bit id (`setBit` i) bt $ go (i + 1) bts
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"