diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -12,12 +12,39 @@ import HaskellWorks.Data.Json.Succinct.Cursor import HaskellWorks.Data.Succinct.BalancedParens.Simple import HaskellWorks.Diagnostics.Time +import System.Mem +readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) +readJson path = do + bs <- BS.readFile path + print "Read file" + !cursor <- measure (fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + print "Created cursor" + return cursor + main :: IO () main = do - bs <- BS.readFile "/Users/jky/Downloads/78mbs.json" - !cursor <- measure (fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) - print (jsonTokenAt (firstChild cursor)) + performGC + !c0 <- readJson "/Users/jky/Downloads/78mbs.json" + !c1 <- readJson "/Users/jky/Downloads/78mbs.json" + !c2 <- readJson "/Users/jky/Downloads/78mbs.json" + !c3 <- readJson "/Users/jky/Downloads/78mbs.json" + !c4 <- readJson "/Users/jky/Downloads/78mbs.json" + !c5 <- readJson "/Users/jky/Downloads/78mbs.json" + !c6 <- readJson "/Users/jky/Downloads/78mbs.json" + !c7 <- readJson "/Users/jky/Downloads/78mbs.json" + !c8 <- readJson "/Users/jky/Downloads/78mbs.json" + !c9 <- readJson "/Users/jky/Downloads/78mbs.json" + print "Returned from readJson" + performGC threadDelay 100000000 - print (jsonTokenAt cursor) - return () + print c0 + print c1 + print c2 + print c3 + print c4 + print c5 + print c6 + print c7 + print c8 + print c9 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -13,8 +13,7 @@ import Data.Word import Foreign import HaskellWorks.Data.Bits.BitShown -import qualified HaskellWorks.Data.Bits.PopCount.PopCount1.Broadword as PC1BW -import qualified HaskellWorks.Data.Bits.PopCount.PopCount1.GHC as PC1GHC +import HaskellWorks.Data.Conduit.ByteString import HaskellWorks.Data.Conduit.Json import HaskellWorks.Data.Conduit.Json.Blank import HaskellWorks.Data.Conduit.List @@ -25,12 +24,18 @@ import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic import System.IO.MMap -v :: DVS.Vector Word64 -v = DVS.fromList (take 1000000 (cycle [maxBound, 0])) +setupEnvBs :: Int -> IO BS.ByteString +setupEnvBs n = return $ BS.pack (take n (cycle [maxBound, 0])) -setupEnv :: IO (DVS.Vector Word64) -setupEnv = return v +setupEnvBss :: Int -> Int -> IO [BS.ByteString] +setupEnvBss n k = setupEnvBs n >>= \v -> return (replicate k v) +setupEnvVector :: Int -> IO (DVS.Vector Word64) +setupEnvVector n = return $ DVS.fromList (take n (cycle [maxBound, 0])) + +setupEnvVectors :: Int -> Int -> IO [DVS.Vector Word64] +setupEnvVectors n k = setupEnvVector n >>= \v -> return (replicate k v) + setupEnvJson :: FilePath -> IO BS.ByteString setupEnvJson filepath = do (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing @@ -43,23 +48,21 @@ runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString runCon con bs = BS.concat $ runListConduit con [bs] -jsonToInterestBits3 :: MonadThrow m => Conduit BS.ByteString m BS.ByteString -jsonToInterestBits3 = blankJson =$= blankedJsonToInterestBits +runCon2 :: Conduit i [] o -> [i] -> [o] +runCon2 con is = let os = runListConduit con is in seq (length os) os -jsonToInterestBitsOld :: MonadThrow m => Conduit BS.ByteString m BS.ByteString -jsonToInterestBitsOld = textToJsonToken =$= jsonToken2Markers =$= markerToByteString +runCon3 :: Conduit i [] BS.ByteString -> [i] -> [BS.ByteString] +runCon3 con is = let os = runListConduit con is in seq (BS.length (last os)) os -runBlankedJsonToInterestBits :: BS.ByteString -> BS.ByteString -runBlankedJsonToInterestBits bs = BS.concat $ runListConduit blankedJsonToInterestBits [bs] +jsonToInterestBits3 :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +jsonToInterestBits3 = blankJson =$= blankedJsonToInterestBits benchRankSelect :: [Benchmark] benchRankSelect = - [ env setupEnv $ \bv -> bgroup "Rank" + [ env (setupEnvVector 1000000) $ \bv -> bgroup "Rank" [ bench "Rank - Once" (whnf (rank1 bv) 1) , bench "Select - Once" (whnf (select1 bv) 1) , bench "Rank - Many" (nf (map (getCount . rank1 bv)) [0, 1000..10000000]) - , bench "PopCnt1 Broadword - Once" (nf (map (\n -> getCount (PC1BW.popCount1 (DVS.take n bv)))) [0, 1000..10000000]) - , bench "PopCnt1 GHC - Once" (nf (map (\n -> getCount (PC1GHC.popCount1 (DVS.take n bv)))) [0, 1000..10000000]) ] ] @@ -68,7 +71,6 @@ [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "Json40" [ bench "Run blankJson " (whnf (runCon blankJson ) bs) , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) - , bench "Run jsonToInterestBitsOld " (whnf (runCon jsonToInterestBitsOld ) bs) , bench "loadJson " (whnf loadJson bs) ] ] @@ -84,6 +86,22 @@ benchRankJsonBigConduits = [ env (setupEnvJson "/Users/jky/Downloads/78mb.json") $ \bs -> bgroup "JsonBig" [ bench "loadJson" (whnf loadJson bs) + ] + ] + +benchBlankedJsonToBalancedParens :: [Benchmark] +benchBlankedJsonToBalancedParens = + [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "JsonBig" + [ bench "blankedJsonToBalancedParens2" (whnf (runCon2 blankedJsonToBalancedParens) [bs]) + , bench "blankedJsonToBalancedParens2" (whnf (runCon3 blankedJsonToBalancedParens2) [bs]) + , bench "blankedJsonToBalancedParens2" (whnf (runCon3 (blankedJsonToBalancedParens2 =$= rechunk 4060)) [bs]) + ] + ] + +benchRechunk :: [Benchmark] +benchRechunk = + [ env (setupEnvBss 4060 19968) $ \bss -> bgroup "Rank" + [ bench "Rechunk" (whnf (runListConduit (rechunk 1000)) bss) ] ] diff --git a/hw-succinct.cabal b/hw-succinct.cabal --- a/hw-succinct.cabal +++ b/hw-succinct.cabal @@ -1,5 +1,5 @@ name: hw-succinct -version: 0.0.0.4 +version: 0.0.0.5 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-succinct#readme @@ -18,53 +18,26 @@ hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 - build-depends: base >= 4 && < 5 , - bytestring , - conduit , - criterion >= 1.1.0.0 && < 1.2 , - hw-succinct , - mmap , - resourcet , - vector >= 0.6 && < 0.12 + build-depends: base >= 4 + , bytestring + , conduit + , criterion + , hw-bits + , hw-succinct + , mmap + , resourcet + , vector default-language: Haskell2010 library hs-source-dirs: src exposed-modules: HaskellWorks.Data.Attoparsec.Final.IsChar - , HaskellWorks.Data.Attoparsec.Final.IsChar.Char - , HaskellWorks.Data.Attoparsec.Final.IsChar.Internal , HaskellWorks.Data.Attoparsec.Final.Parser - , HaskellWorks.Data.Attoparsec.Final.Parser.ByteString - , HaskellWorks.Data.Attoparsec.Final.Parser.Internal - , HaskellWorks.Data.Attoparsec.Final.Parser.Text - , HaskellWorks.Data.Bits - , HaskellWorks.Data.Bits.BitLength - , HaskellWorks.Data.Bits.BitParse - , HaskellWorks.Data.Bits.BitRead - , HaskellWorks.Data.Bits.BitShow - , HaskellWorks.Data.Bits.BitShown - , HaskellWorks.Data.Bits.BitWise - , HaskellWorks.Data.Bits.BitWise.String - , HaskellWorks.Data.Bits.Conversion - , HaskellWorks.Data.Bits.ElemFixedBitSize - , HaskellWorks.Data.Bits.FixedBitSize - , HaskellWorks.Data.Bits.FromBools - , HaskellWorks.Data.Bits.PopCount - , HaskellWorks.Data.Bits.PopCount.PopCount0 - , HaskellWorks.Data.Bits.PopCount.PopCount1 - , HaskellWorks.Data.Bits.PopCount.PopCount1.Broadword - , HaskellWorks.Data.Bits.PopCount.PopCount1.GHC - , HaskellWorks.Data.ByteString + , HaskellWorks.Data.Conduit.ByteString , HaskellWorks.Data.Conduit.Json , HaskellWorks.Data.Conduit.Json.Blank , HaskellWorks.Data.Conduit.Json.Words , HaskellWorks.Data.Conduit.List - , HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Internal - , HaskellWorks.Data.Conduit.Tokenize.Attoparsec.LineColumn - , HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Offset - , HaskellWorks.Data.Conduit.Tokenize.Attoparsec - , HaskellWorks.Data.FromByteString - , HaskellWorks.Data.FromForeignRegion , HaskellWorks.Data.Json.Final.Tokenize , HaskellWorks.Data.Json.Final.Tokenize.Internal , HaskellWorks.Data.Json.Succinct @@ -74,10 +47,7 @@ , HaskellWorks.Data.Json.Succinct.Cursor.CursorType , HaskellWorks.Data.Json.Succinct.Cursor.InterestBits , HaskellWorks.Data.Json.Succinct.Cursor.Internal - , HaskellWorks.Data.Json.Succinct.Transform , HaskellWorks.Data.Json.Token - , HaskellWorks.Data.Positioning - , HaskellWorks.Data.Search , HaskellWorks.Data.Succinct , HaskellWorks.Data.Succinct.BalancedParens , HaskellWorks.Data.Succinct.BalancedParens.Internal @@ -92,12 +62,6 @@ , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 , HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 , HaskellWorks.Data.Succinct.RankSelect.Internal - , HaskellWorks.Data.Vector.BoxedVectorLike - , HaskellWorks.Data.Vector.Storable.ByteString - , HaskellWorks.Data.Vector.StorableVectorLike - , HaskellWorks.Data.Vector.VectorLike - , HaskellWorks.Data.Word - , HaskellWorks.Function , HaskellWorks.Diagnostics.Time build-depends: base >= 4.7 && < 5 , array @@ -106,6 +70,7 @@ , conduit >= 1.1 && < 1.3 , deepseq < 1.5 , ghc-prim + , hw-bits , lens , mmap , mono-traversable @@ -127,28 +92,26 @@ main-is: Spec.hs other-modules: HaskellWorks.Data.Bits.BitReadSpec , HaskellWorks.Data.Bits.BitWiseSpec - , HaskellWorks.Data.Bits.FromBoolsSpec + , HaskellWorks.Data.Conduit.ByteStringSpec , HaskellWorks.Data.Conduit.Json.BlankSpec - , HaskellWorks.Data.Conduit.JsonSpec - , HaskellWorks.Data.Conduit.Tokenize.Attoparsec.LineColumnSpec - , HaskellWorks.Data.Conduit.Tokenize.Attoparsec.OffsetSpec , HaskellWorks.Data.Json.Final.TokenizeSpec , HaskellWorks.Data.Json.Succinct.CursorSpec - , HaskellWorks.Data.Json.SuccinctSpec + , HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec , HaskellWorks.Data.Succinct.BalancedParensSpec - , HaskellWorks.Data.Succinct.RankSelect.InternalSpec , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0Spec , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1Spec , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0Spec , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1Spec , HaskellWorks.Data.Succinct.RankSelect.Binary.BasicGen , HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512Spec + , HaskellWorks.Data.Succinct.RankSelect.InternalSpec , HaskellWorks.Data.Succinct.SimpleSpec build-depends: base , attoparsec >= 0.10 , bytestring , conduit >= 1.1 && < 1.3 , hspec >= 1.3 + , hw-bits , hw-succinct , mmap , parsec @@ -169,13 +132,12 @@ Main-Is: Main.hs GHC-Options: -O2 -Wall -msse4.2 Default-Language: Haskell2010 - Build-Depends: - base >= 4 && < 5 , - bytestring , - conduit , - criterion >= 1.1.0.0 && < 1.2 , - hw-succinct , - mmap , - resourcet , - vector >= 0.6 && < 0.12 - + Build-Depends: base >= 4 && < 5 + , bytestring + , conduit + , criterion + , hw-bits + , hw-succinct + , mmap + , resourcet + , vector diff --git a/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs b/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs --- a/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs +++ b/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs @@ -1,6 +1,17 @@ module HaskellWorks.Data.Attoparsec.Final.IsChar - ( module X + ( IsChar(..) ) where -import HaskellWorks.Data.Attoparsec.Final.IsChar.Char as X () -import HaskellWorks.Data.Attoparsec.Final.IsChar.Internal as X +import qualified Data.ByteString.Internal as BI +import Data.Word8 + +class IsChar c where + toChar :: c -> Char + +instance IsChar Word8 where + toChar = BI.w2c + {-# INLINABLE toChar #-} + +instance IsChar Char where + toChar = id + {-# INLINABLE toChar #-} diff --git a/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Char.hs b/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Char.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Char.hs +++ /dev/null @@ -1,8 +0,0 @@ -module HaskellWorks.Data.Attoparsec.Final.IsChar.Char - ( IsChar(..) - ) where - -import HaskellWorks.Data.Attoparsec.Final.IsChar.Internal - -instance IsChar Char where - toChar = id diff --git a/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Internal.hs b/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Internal.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Internal.hs +++ /dev/null @@ -1,12 +0,0 @@ -module HaskellWorks.Data.Attoparsec.Final.IsChar.Internal - ( IsChar(..) - ) where - -import qualified Data.ByteString.Internal as BI -import Data.Word8 - -class IsChar c where - toChar :: c -> Char - -instance IsChar Word8 where - toChar = BI.w2c diff --git a/src/HaskellWorks/Data/Attoparsec/Final/Parser.hs b/src/HaskellWorks/Data/Attoparsec/Final/Parser.hs --- a/src/HaskellWorks/Data/Attoparsec/Final/Parser.hs +++ b/src/HaskellWorks/Data/Attoparsec/Final/Parser.hs @@ -1,5 +1,58 @@ module HaskellWorks.Data.Attoparsec.Final.Parser - ( Parser(..) - ) where + ( Parser(..) + ) where -import HaskellWorks.Data.Attoparsec.Final.Parser.Internal +import qualified Data.Attoparsec.ByteString as ABS +import qualified Data.Attoparsec.ByteString.Char8 as BC +import qualified Data.Attoparsec.Text as AT +import qualified Data.Attoparsec.Types as T +import Data.ByteString (ByteString) +import Data.MonoTraversable +import Data.Text (Text) +import HaskellWorks.Data.Attoparsec.Final.IsChar + +class MonoTraversable t => Parser t where + satisfy :: (Element t -> Bool) -> T.Parser t (Element t) + satisfyWith :: (Element t -> a) -> (a -> Bool) -> T.Parser t a + satisfyChar :: (Char -> Bool) -> T.Parser t Char + string :: t -> T.Parser t t + try :: T.Parser t a -> T.Parser t a + char :: Char -> T.Parser t Char + () :: T.Parser t Char -> String -> T.Parser t Char + rational :: Fractional f => T.Parser t f + +instance Parser ByteString where + satisfy = ABS.satisfy + satisfyWith = ABS.satisfyWith + satisfyChar = ABS.satisfyWith toChar + string = ABS.string + try = ABS.try + char = BC.char + () = (BC.) + rational = BC.rational + {-# INLINABLE satisfy #-} + {-# INLINABLE satisfyWith #-} + {-# INLINABLE satisfyChar #-} + {-# INLINABLE string #-} + {-# INLINABLE try #-} + {-# INLINABLE char #-} + {-# INLINABLE () #-} + {-# INLINABLE rational #-} + +instance Parser Text where + satisfy = AT.satisfy + satisfyWith = AT.satisfyWith + satisfyChar = AT.satisfyWith toChar + string = AT.string + try = AT.try + char = AT.char + () = (AT.) + rational = AT.rational + {-# INLINABLE satisfy #-} + {-# INLINABLE satisfyWith #-} + {-# INLINABLE satisfyChar #-} + {-# INLINABLE string #-} + {-# INLINABLE try #-} + {-# INLINABLE char #-} + {-# INLINABLE () #-} + {-# INLINABLE rational #-} diff --git a/src/HaskellWorks/Data/Attoparsec/Final/Parser/ByteString.hs b/src/HaskellWorks/Data/Attoparsec/Final/Parser/ByteString.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Attoparsec/Final/Parser/ByteString.hs +++ /dev/null @@ -1,17 +0,0 @@ -module HaskellWorks.Data.Attoparsec.Final.Parser.ByteString where - -import qualified Data.Attoparsec.ByteString as ABS -import qualified Data.Attoparsec.ByteString.Char8 as BC -import Data.ByteString (ByteString) -import HaskellWorks.Data.Attoparsec.Final.IsChar -import HaskellWorks.Data.Attoparsec.Final.Parser.Internal - -instance Parser ByteString where - satisfy = ABS.satisfy - satisfyWith = ABS.satisfyWith - satisfyChar = ABS.satisfyWith toChar - string = ABS.string - try = ABS.try - char = BC.char - () = (BC.) - rational = BC.rational diff --git a/src/HaskellWorks/Data/Attoparsec/Final/Parser/Internal.hs b/src/HaskellWorks/Data/Attoparsec/Final/Parser/Internal.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Attoparsec/Final/Parser/Internal.hs +++ /dev/null @@ -1,16 +0,0 @@ -module HaskellWorks.Data.Attoparsec.Final.Parser.Internal - ( Parser(..) - ) where - -import qualified Data.Attoparsec.Types as T -import Data.MonoTraversable - -class MonoTraversable t => Parser t where - satisfy :: (Element t -> Bool) -> T.Parser t (Element t) - satisfyWith :: (Element t -> a) -> (a -> Bool) -> T.Parser t a - satisfyChar :: (Char -> Bool) -> T.Parser t Char - string :: t -> T.Parser t t - try :: T.Parser t a -> T.Parser t a - char :: Char -> T.Parser t Char - () :: T.Parser t Char -> String -> T.Parser t Char - rational :: Fractional f => T.Parser t f diff --git a/src/HaskellWorks/Data/Attoparsec/Final/Parser/Text.hs b/src/HaskellWorks/Data/Attoparsec/Final/Parser/Text.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Attoparsec/Final/Parser/Text.hs +++ /dev/null @@ -1,16 +0,0 @@ -module HaskellWorks.Data.Attoparsec.Final.Parser.Text where - -import qualified Data.Attoparsec.Text as AT -import Data.Text (Text) -import HaskellWorks.Data.Attoparsec.Final.IsChar -import HaskellWorks.Data.Attoparsec.Final.Parser.Internal - -instance Parser Text where - satisfy = AT.satisfy - satisfyWith = AT.satisfyWith - satisfyChar = AT.satisfyWith toChar - string = AT.string - try = AT.try - char = AT.char - () = (AT.) - rational = AT.rational diff --git a/src/HaskellWorks/Data/Bits.hs b/src/HaskellWorks/Data/Bits.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits - ( module X - ) where - -import HaskellWorks.Data.Bits.BitLength as X -import HaskellWorks.Data.Bits.BitParse as X -import HaskellWorks.Data.Bits.BitRead as X -import HaskellWorks.Data.Bits.BitShow as X -import HaskellWorks.Data.Bits.BitShown as X -import HaskellWorks.Data.Bits.BitWise as X -import HaskellWorks.Data.Bits.PopCount as X diff --git a/src/HaskellWorks/Data/Bits/BitLength.hs b/src/HaskellWorks/Data/Bits/BitLength.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitLength.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.BitLength - ( -- * Bit map - BitLength(..) - , elemBitLength - , elemBitEnd - ) where - -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.Vector.VectorLike -import Prelude as P - -class BitLength v where - bitLength :: v -> Count - - endPosition :: v -> Position - endPosition = Position . fromIntegral . getCount . bitLength - --------------------------------------------------------------------------------- --- Functions - -elemBitLength :: (VectorLike v, BitLength (Elem v)) => v -> Count -elemBitLength v = bitLength (v !!! 0) - -elemBitEnd :: (VectorLike v, BitLength (Elem v)) => v -> Position -elemBitEnd v = endPosition (v !!! 0) - --------------------------------------------------------------------------------- --- Instances - -instance BitLength Bool where - bitLength _ = 1 - {-# INLINABLE bitLength #-} - -instance BitLength [Bool] where - bitLength = fromIntegral . P.length - {-# INLINABLE bitLength #-} - -instance BitLength Word8 where - bitLength _ = 8 - {-# INLINABLE bitLength #-} - -instance BitLength Word16 where - bitLength _ = 16 - {-# INLINABLE bitLength #-} - -instance BitLength Word32 where - bitLength _ = 32 - {-# INLINABLE bitLength #-} - -instance BitLength Word64 where - bitLength _ = 64 - {-# INLINABLE bitLength #-} - -instance BitLength [Word8] where - bitLength v = fromIntegral (P.length v) * bitLength (head v) - {-# INLINABLE bitLength #-} - -instance BitLength [Word16] where - bitLength v = fromIntegral (P.length v) * bitLength (head v) - {-# INLINABLE bitLength #-} - -instance BitLength [Word32] where - bitLength v = fromIntegral (P.length v) * bitLength (head v) - {-# INLINABLE bitLength #-} - -instance BitLength [Word64] where - bitLength v = fromIntegral (P.length v) * bitLength (head v) - {-# INLINABLE bitLength #-} - -instance BitLength (DV.Vector Word8) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DV.Vector Word16) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DV.Vector Word32) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DV.Vector Word64) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DVS.Vector Word8) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DVS.Vector Word16) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DVS.Vector Word32) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} - -instance BitLength (DVS.Vector Word64) where - bitLength v = vLength v * bitLength (v !!! 0) - {-# INLINABLE bitLength #-} diff --git a/src/HaskellWorks/Data/Bits/BitParse.hs b/src/HaskellWorks/Data/Bits/BitParse.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitParse.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.BitParse - ( BitParse(..) - ) where - -import qualified Data.ByteString as BS -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitLength -import HaskellWorks.Data.Bits.BitWise -import Text.ParserCombinators.Parsec - -class BitParse a where - bitParse0 :: Parser a - bitParse1 :: Parser a - -p0 :: Parser Bool -p0 = char '1' >> return True - -p1 :: Parser Bool -p1 = char '0' >> return False - -instance BitParse Bool where - bitParse0 = option False bitParse1 - bitParse1 = p0 <|> p1 - -instance BitParse Word8 where - bitParse0 = option 0 bitParse1 - bitParse1 = do - a :: Bool <- bitParse1 - b :: Bool <- bitParse0 - c :: Bool <- bitParse0 - d :: Bool <- bitParse0 - e :: Bool <- bitParse0 - f :: Bool <- bitParse0 - g :: Bool <- bitParse0 - h :: Bool <- bitParse0 - return $ - (if a then 0x01 else 0) .|. - (if b then 0x02 else 0) .|. - (if c then 0x04 else 0) .|. - (if d then 0x08 else 0) .|. - (if e then 0x10 else 0) .|. - (if f then 0x20 else 0) .|. - (if g then 0x40 else 0) .|. - (if h then 0x80 else 0) - -instance BitParse Word16 where - bitParse0 = option 0 bitParse1 - bitParse1 = do - (a :: Word8) <- bitParse1 - (b :: Word8) <- bitParse0 - return $ (fromIntegral b .<. bitLength a) .|. fromIntegral a - -instance BitParse Word32 where - bitParse0 = option 0 bitParse1 - bitParse1 = do - (a :: Word16) <- bitParse1 - (b :: Word16) <- bitParse0 - return $ (fromIntegral b .<. bitLength a) .|. fromIntegral a - -instance BitParse Word64 where - bitParse0 = option 0 bitParse1 - bitParse1 = do - (a :: Word32) <- bitParse1 - (b :: Word32) <- bitParse0 - return $ (fromIntegral b .<. bitLength a) .|. fromIntegral a - -instance BitParse BS.ByteString where - bitParse0 = fmap BS.pack bitParse0 - bitParse1 = fmap BS.pack bitParse1 - -instance BitParse [Word8] where - bitParse0 = option [] bitParse1 - bitParse1 = many bitParse1 - -instance BitParse [Word16] where - bitParse0 = option [] bitParse1 - bitParse1 = many bitParse1 - -instance BitParse [Word32] where - bitParse0 = option [] bitParse1 - bitParse1 = many bitParse1 - -instance BitParse [Word64] where - bitParse0 = option [] bitParse1 - bitParse1 = many bitParse1 - -instance BitParse (DV.Vector Word8) where - bitParse0 = option DV.empty bitParse1 - bitParse1 = DV.fromList `fmap` bitParse0 - -instance BitParse (DV.Vector Word16) where - bitParse0 = option DV.empty bitParse1 - bitParse1 = DV.fromList `fmap` bitParse0 - -instance BitParse (DV.Vector Word32) where - bitParse0 = option DV.empty bitParse1 - bitParse1 = DV.fromList `fmap` bitParse0 - -instance BitParse (DV.Vector Word64) where - bitParse0 = option DV.empty bitParse1 - bitParse1 = DV.fromList `fmap` bitParse0 - -instance BitParse (DVS.Vector Word8) where - bitParse0 = option DVS.empty bitParse1 - bitParse1 = DVS.fromList `fmap` bitParse0 - -instance BitParse (DVS.Vector Word16) where - bitParse0 = option DVS.empty bitParse1 - bitParse1 = DVS.fromList `fmap` bitParse0 - -instance BitParse (DVS.Vector Word32) where - bitParse0 = option DVS.empty bitParse1 - bitParse1 = DVS.fromList `fmap` bitParse0 - -instance BitParse (DVS.Vector Word64) where - bitParse0 = option DVS.empty bitParse1 - bitParse1 = DVS.fromList `fmap` bitParse0 diff --git a/src/HaskellWorks/Data/Bits/BitRead.hs b/src/HaskellWorks/Data/Bits/BitRead.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitRead.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module HaskellWorks.Data.Bits.BitRead - ( BitRead(..) - ) where - -import qualified Data.ByteString as BS -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitParse -import Text.ParserCombinators.Parsec - -class BitRead a where - bitRead :: String -> Maybe a - -bitRead' :: BitParse a => String -> Maybe a -bitRead' = either (const Nothing) Just . parse bitParse0 "" . filter (/= ' ') - -bitCharToBool :: Char -> Maybe Bool -bitCharToBool '1' = Just True -bitCharToBool '0' = Just False -bitCharToBool _ = Nothing - -instance BitRead Word8 where - bitRead = bitRead' - -instance BitRead Word16 where - bitRead = bitRead' - -instance BitRead Word32 where - bitRead = bitRead' - -instance BitRead Word64 where - bitRead = bitRead' - -instance BitRead BS.ByteString where - bitRead = bitRead' - -instance BitRead [Word8] where - bitRead = bitRead' - -instance BitRead [Word16] where - bitRead = bitRead' - -instance BitRead [Word32] where - bitRead = bitRead' - -instance BitRead [Word64] where - bitRead = bitRead' - -instance BitRead (DV.Vector Word8) where - bitRead = bitRead' - -instance BitRead (DV.Vector Word16) where - bitRead = bitRead' - -instance BitRead (DV.Vector Word32) where - bitRead = bitRead' - -instance BitRead (DV.Vector Word64) where - bitRead = bitRead' - -instance BitRead (DVS.Vector Word8) where - bitRead = bitRead' - -instance BitRead (DVS.Vector Word16) where - bitRead = bitRead' - -instance BitRead (DVS.Vector Word32) where - bitRead = bitRead' - -instance BitRead (DVS.Vector Word64) where - bitRead = bitRead' - -instance BitRead [Bool] where - bitRead = sequence . fmap bitCharToBool . filter (/= ' ') diff --git a/src/HaskellWorks/Data/Bits/BitShow.hs b/src/HaskellWorks/Data/Bits/BitShow.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitShow.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.BitShow - ( BitShow(..) - , bitShow - ) where - -import qualified Data.ByteString as BS -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Word - -class BitShow a where - bitShows :: a -> String -> String - -instance BitShow Bool where - bitShows a = ((if a then '1' else '0'):) - -instance BitShow Word8 where - bitShows w = - (if w .?. 0 then ('1':) else ('0':)) - . (if w .?. 1 then ('1':) else ('0':)) - . (if w .?. 2 then ('1':) else ('0':)) - . (if w .?. 3 then ('1':) else ('0':)) - . (if w .?. 4 then ('1':) else ('0':)) - . (if w .?. 5 then ('1':) else ('0':)) - . (if w .?. 6 then ('1':) else ('0':)) - . (if w .?. 7 then ('1':) else ('0':)) - -instance BitShow Word16 where - bitShows w = case leSplit w of (a, b) -> bitShows a . (' ':) . bitShows b - -instance BitShow Word32 where - bitShows w = case leSplit w of (a, b) -> bitShows a . (' ':) . bitShows b - -instance BitShow Word64 where - bitShows w = case leSplit w of (a, b) -> bitShows a . (' ':) . bitShows b - -instance BitShow [Bool] where - bitShows ws = ('\"':) . go (0 :: Int) ws . ('\"':) - where go _ [] = id - go _ [u] = bitShows u - go n (u:us) = bitShows u . maybePrependSeperatorat n . go (n + 1) us - maybePrependSeperatorat n = if n `mod` 8 == 7 then (' ':) else id - -instance BitShow BS.ByteString where - bitShows bs | BS.length bs == 0 = id - bitShows bs | BS.length bs == 1 = bitShows (BS.head bs) - bitShows bs = bitShows (BS.head bs) . (' ':) . bitShows (BS.tail bs) - -instance BitShow [Word8] where - bitShows [] = id - bitShows [w] = bitShows w - bitShows (w:ws) = bitShows w . (' ':) . bitShows ws - -instance BitShow [Word16] where - bitShows [] = id - bitShows [w] = bitShows w - bitShows (w:ws) = bitShows w . (' ':) . bitShows ws - -instance BitShow [Word32] where - bitShows [] = id - bitShows [w] = bitShows w - bitShows (w:ws) = bitShows w . (' ':) . bitShows ws - -instance BitShow [Word64] where - bitShows [] = id - bitShows [w] = bitShows w - bitShows (w:ws) = bitShows w . (' ':) . bitShows ws - -instance BitShow (DV.Vector Word8) where - bitShows = bitShows . DV.toList - -instance BitShow (DV.Vector Word16) where - bitShows = bitShows . DV.toList - -instance BitShow (DV.Vector Word32) where - bitShows = bitShows . DV.toList - -instance BitShow (DV.Vector Word64) where - bitShows = bitShows . DV.toList - -instance BitShow (DVS.Vector Word8) where - bitShows = bitShows . DVS.toList - -instance BitShow (DVS.Vector Word16) where - bitShows = bitShows . DVS.toList - -instance BitShow (DVS.Vector Word32) where - bitShows = bitShows . DVS.toList - -instance BitShow (DVS.Vector Word64) where - bitShows = bitShows . DVS.toList - -bitShow :: BitShow a => a -> String -bitShow a = bitShows a "" diff --git a/src/HaskellWorks/Data/Bits/BitShown.hs b/src/HaskellWorks/Data/Bits/BitShown.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitShown.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} - -module HaskellWorks.Data.Bits.BitShown - ( BitShown(..) - , bitShown - ) where - -import qualified Data.ByteString as BS -import Data.Maybe -import Data.String -import Data.Word -import HaskellWorks.Data.Bits.BitRead -import HaskellWorks.Data.Bits.BitShow -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.FromByteString - -newtype BitShown a = BitShown a deriving (Eq, BitRead, BitShow) - -deriving instance Functor BitShown - -instance BitRead a => IsString (BitShown a) where - fromString = fromJust . bitRead - -instance BitShow a => Show (BitShown a) where - show a = bitShows a "" - -bitShown :: BitShown a -> a -bitShown (BitShown a) = a - -deriving instance TestBit a => TestBit (BitShown a) - -instance FromByteString (BitShown [Bool]) where - fromByteString = BitShown . BS.foldr gen [] - where gen :: Word8 -> [Bool] -> [Bool] - gen w bs = - (w .&. 0x01 /= 0) : - (w .&. 0x02 /= 0) : - (w .&. 0x04 /= 0) : - (w .&. 0x08 /= 0) : - (w .&. 0x10 /= 0) : - (w .&. 0x20 /= 0) : - (w .&. 0x40 /= 0) : - (w .&. 0x80 /= 0) : bs diff --git a/src/HaskellWorks/Data/Bits/BitWise.hs b/src/HaskellWorks/Data/Bits/BitWise.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitWise.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.BitWise - ( -- * Bit map - BitWise(..) - , Shift(..) - , TestBit(..) - ) where - -import qualified Data.Bits as B -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitLength -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.Vector.VectorLike as VL -import Prelude as P - --- We pervasively use precedence to avoid excessive parentheses, and we use --- the same precedence conventions of the C programming language: arithmetic --- operators come first, ordered in the standard way, followed by shifts, --- followed by logical operators; ⊕ sits between | and &. -infixl 9 .?. -infixl 8 .<., .>. -infixl 7 .&. -- Bitwise AND. eg. ∧ -infixl 6 .^. -- Bitwise XOR. eg. ⊕ -infixl 5 .|. -- Bitwise OR. eg. ∨ - -class Shift a where - (.<.) :: a -> Count -> a - (.>.) :: a -> Count -> a - -class TestBit a where - (.?.) :: a -> Position -> Bool - -class BitWise a where - (.&.) :: a -> a -> a - (.|.) :: a -> a -> a - (.^.) :: a -> a -> a - comp :: a -> a - all0s :: a - all1s :: a - --------------------------------------------------------------------------------- --- Instances - -instance TestBit Bool where - (.?.) w 0 = w - (.?.) _ _ = error "Invalid bit index" - {-# INLINABLE (.?.) #-} - -instance TestBit [Bool] where - (.?.) v p = v !! fromIntegral p - {-# INLINABLE (.?.) #-} - -instance TestBit Word8 where - (.?.) w n = B.testBit w (fromIntegral (getPosition n)) - {-# INLINABLE (.?.) #-} - -instance TestBit Word16 where - (.?.) w n = B.testBit w (fromIntegral (getPosition n)) - {-# INLINABLE (.?.) #-} - -instance TestBit Word32 where - (.?.) w n = B.testBit w (fromIntegral (getPosition n)) - {-# INLINABLE (.?.) #-} - -instance TestBit Word64 where - (.?.) w n = B.testBit w (fromIntegral (getPosition n)) - {-# INLINABLE (.?.) #-} - -instance TestBit (DV.Vector Word8) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DV.Vector Word16) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DV.Vector Word32) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DV.Vector Word64) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DVS.Vector Word8) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DVS.Vector Word16) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DVS.Vector Word32) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance TestBit (DVS.Vector Word64) where - (.?.) v n = let (q, r) = n `quotRem` elemBitEnd v in (v !!! q) .?. r - {-# INLINABLE (.?.) #-} - -instance BitWise Word8 where - (.&.) = (B..&.) - {-# INLINABLE (.&.) #-} - - (.|.) = (B..|.) - {-# INLINABLE (.|.) #-} - - (.^.) = B.xor - {-# INLINABLE (.^.) #-} - - comp = B.complement - {-# INLINABLE comp #-} - - all0s = 0 - {-# INLINABLE all0s #-} - - all1s = 0 - {-# INLINABLE all1s #-} - -instance BitWise Word16 where - (.&.) = (B..&.) - {-# INLINABLE (.&.) #-} - - (.|.) = (B..|.) - {-# INLINABLE (.|.) #-} - - (.^.) = B.xor - {-# INLINABLE (.^.) #-} - - comp = B.complement - {-# INLINABLE comp #-} - - all0s = 0 - {-# INLINABLE all0s #-} - - all1s = 0 - {-# INLINABLE all1s #-} - -instance BitWise Word32 where - (.&.) = (B..&.) - {-# INLINABLE (.&.) #-} - - (.|.) = (B..|.) - {-# INLINABLE (.|.) #-} - - (.^.) = B.xor - {-# INLINABLE (.^.) #-} - - comp = B.complement - {-# INLINABLE comp #-} - - all0s = 0 - {-# INLINABLE all0s #-} - - all1s = 0 - {-# INLINABLE all1s #-} - -instance BitWise Word64 where - (.&.) = (B..&.) - {-# INLINABLE (.&.) #-} - - (.|.) = (B..|.) - {-# INLINABLE (.|.) #-} - - (.^.) = B.xor - {-# INLINABLE (.^.) #-} - - comp = B.complement - {-# INLINABLE comp #-} - - all0s = 0 - {-# INLINABLE all0s #-} - - all1s = 0 - {-# INLINABLE all1s #-} - -instance Shift Word8 where - (.<.) w n = B.shiftL w (fromIntegral n) - {-# INLINABLE (.<.) #-} - - (.>.) w n = B.shiftR w (fromIntegral n) - {-# INLINABLE (.>.) #-} - -instance Shift Word16 where - (.<.) w n = B.shiftL w (fromIntegral n) - {-# INLINABLE (.<.) #-} - - (.>.) w n = B.shiftR w (fromIntegral n) - {-# INLINABLE (.>.) #-} - -instance Shift Word32 where - (.<.) w n = B.shiftL w (fromIntegral n) - {-# INLINABLE (.<.) #-} - - (.>.) w n = B.shiftR w (fromIntegral n) - {-# INLINABLE (.>.) #-} - -instance Shift Word64 where - (.<.) w n = B.shiftL w (fromIntegral n) - {-# INLINABLE (.<.) #-} - - (.>.) w n = B.shiftR w (fromIntegral n) - {-# INLINABLE (.>.) #-} diff --git a/src/HaskellWorks/Data/Bits/BitWise/String.hs b/src/HaskellWorks/Data/Bits/BitWise/String.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/BitWise/String.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module HaskellWorks.Data.Bits.BitWise.String - ( AsBits(..) - , FromBits(..) - , bitsToString - , bitsShows - , fromBitsDiff - , fromBitsDiffN - , stringToBits - ) where - -import Data.Bits -import Data.Word - -bitsDiff' :: FiniteBits a => a -> Int -> Int -> [Bool] -> [Bool] -bitsDiff' a n len bs - | n < len = testBit a n : bitsDiff' a (n + 1) len bs - | n == len = bs - | otherwise = error "Invalid index" - -bits :: AsBits a => a -> [Bool] -bits a = bitsDiff a [] - -bitsShows' :: [Bool] -> ShowS -bitsShows' [] s = s -bitsShows' (True :bs) s = '1':bitsShows' bs s -bitsShows' (False:bs) s = '0':bitsShows' bs s - -bitsShows :: AsBits a => a -> ShowS -bitsShows = bitsShows' . bits - -bitsToString :: AsBits a => a -> String -bitsToString bs = bitsShows bs "" - --- unbits :: AsBits a => [Bool] -> (a, [Bool]) --- unbits a = _uu - - --- bitsUnshows :: AsBits a => String -> (a, String) --- bitsUnshows = bitsShows' . bits --- --- stringToBits :: AsBits a => String -> (a, String) --- stringToBits as = _u - -class AsBits a where - bitsDiff :: a -> [Bool] -> [Bool] - -class FromBits a where - fromBits1 :: [Bool] -> (Maybe a, [Bool]) - --------------------------------------------------------------------------------- - -instance AsBits Bool where - bitsDiff = (:) - -instance AsBits Word8 where - bitsDiff a = bitsDiff' a 0 (finiteBitSize a) - -instance AsBits a => AsBits [a] where - bitsDiff [] = id - bitsDiff (x:xs) = bitsDiff x . bitsDiff xs - -instance FromBits Bool where - fromBits1 [] = (Nothing, []) - fromBits1 (b:bs) = (Just b, bs) - -instance FromBits Word8 where - fromBits1 (a:b:c:d:e:f:g:h:bs) = (,) - (Just $ if a then 0x01 else 0 .|. - if b then 0x02 else 0 .|. - if c then 0x04 else 0 .|. - if d then 0x08 else 0 .|. - if e then 0x10 else 0 .|. - if f then 0x20 else 0 .|. - if g then 0x40 else 0 .|. - if h then 0x80 else 0) - bs - fromBits1 bs = (Nothing, bs) - -instance FromBits Word16 where - fromBits1 (a:b:c:d:e:f:g:h:i:j:k:l:m:n:o:p:bs) = (,) - (Just $ if a then 0x0001 else 0 .|. - if b then 0x0002 else 0 .|. - if c then 0x0004 else 0 .|. - if d then 0x0008 else 0 .|. - if e then 0x0010 else 0 .|. - if f then 0x0020 else 0 .|. - if g then 0x0040 else 0 .|. - if h then 0x0080 else 0 .|. - if i then 0x0100 else 0 .|. - if j then 0x0200 else 0 .|. - if k then 0x0400 else 0 .|. - if l then 0x0800 else 0 .|. - if m then 0x1000 else 0 .|. - if n then 0x2000 else 0 .|. - if o then 0x4000 else 0 .|. - if p then 0x8000 else 0) - bs - fromBits1 bs = (Nothing, bs) - -fromBitsDiff :: FromBits a => [Bool] -> ([a] -> [a], [Bool]) -fromBitsDiff bs = case fromBits1 bs of - (Nothing, rs) -> (id , rs) - (Just a , rs) -> case fromBitsDiff rs of - (f, ss) -> ((a:) . f, ss) - -fromBitsDiffN :: FromBits a => Int -> [Bool] -> ([a] -> [a], [Bool]) -fromBitsDiffN n bs - | n > 0 = case fromBits1 bs of - (Nothing, rs) -> (id , rs) - (Just a , rs) -> case fromBitsDiffN (n - 1) rs of - (f, ss) -> ((a:) . f, ss) - | n == 0 = (id, bs) - | n < 0 = error "Invalid count" - | null bs = (id, []) - | otherwise = error "Error" - -stringToBits :: String -> [Bool] -stringToBits [] = [] -stringToBits ('1' :xs) = True :stringToBits xs -stringToBits ('0' :xs) = False:stringToBits xs -stringToBits (' ' :xs) = stringToBits xs -stringToBits ('\n':xs) = stringToBits xs -stringToBits (_ :_ ) = error "Invalid bit" diff --git a/src/HaskellWorks/Data/Bits/Conversion.hs b/src/HaskellWorks/Data/Bits/Conversion.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/Conversion.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module HaskellWorks.Data.Bits.Conversion - ( AsBits(..) - , FromBits(..) - , bitsToString - , bitsShows - , fromBitsDiff - , fromBitsDiffN - , stringToBits - ) - where - -import Data.Bits -import Data.Word - -bitsDiff' :: FiniteBits a => a -> Int -> Int -> [Bool] -> [Bool] -bitsDiff' a n len bs - | n < len = testBit a n : bitsDiff' a (n + 1) len bs - | n == len = bs - | otherwise = error "Invalid index" - -bits :: AsBits a => a -> [Bool] -bits a = bitsDiff a [] - -bitsShows' :: [Bool] -> ShowS -bitsShows' [] s = s -bitsShows' (True :bs) s = '1':bitsShows' bs s -bitsShows' (False:bs) s = '0':bitsShows' bs s - -bitsShows :: AsBits a => a -> ShowS -bitsShows = bitsShows' . bits - -bitsToString :: AsBits a => a -> String -bitsToString bs = bitsShows bs "" - --- unbits :: AsBits a => [Bool] -> (a, [Bool]) --- unbits a = _uu - - --- bitsUnshows :: AsBits a => String -> (a, String) --- bitsUnshows = bitsShows' . bits --- --- stringToBits :: AsBits a => String -> (a, String) --- stringToBits as = _u - -class AsBits a where - bitsDiff :: a -> [Bool] -> [Bool] - -class FromBits a where - fromBits1 :: [Bool] -> (Maybe a, [Bool]) - --------------------------------------------------------------------------------- - -instance AsBits Bool where - bitsDiff = (:) - -instance AsBits Word8 where - bitsDiff a = bitsDiff' a 0 (finiteBitSize a) - -instance AsBits a => AsBits [a] where - bitsDiff [] = id - bitsDiff (x:xs) = bitsDiff x . bitsDiff xs - -instance FromBits Bool where - fromBits1 [] = (Nothing, []) - fromBits1 (b:bs) = (Just b, bs) - -instance FromBits Word8 where - fromBits1 (a:b:c:d:e:f:g:h:bs) = (,) - (Just $ if a then 0x01 else 0 .|. - if b then 0x02 else 0 .|. - if c then 0x04 else 0 .|. - if d then 0x08 else 0 .|. - if e then 0x10 else 0 .|. - if f then 0x20 else 0 .|. - if g then 0x40 else 0 .|. - if h then 0x80 else 0) - bs - fromBits1 bs = (Nothing, bs) - -instance FromBits Word16 where - fromBits1 (a:b:c:d:e:f:g:h:i:j:k:l:m:n:o:p:bs) = (,) - (Just $ if a then 0x0001 else 0 .|. - if b then 0x0002 else 0 .|. - if c then 0x0004 else 0 .|. - if d then 0x0008 else 0 .|. - if e then 0x0010 else 0 .|. - if f then 0x0020 else 0 .|. - if g then 0x0040 else 0 .|. - if h then 0x0080 else 0 .|. - if i then 0x0100 else 0 .|. - if j then 0x0200 else 0 .|. - if k then 0x0400 else 0 .|. - if l then 0x0800 else 0 .|. - if m then 0x1000 else 0 .|. - if n then 0x2000 else 0 .|. - if o then 0x4000 else 0 .|. - if p then 0x8000 else 0) - bs - fromBits1 bs = (Nothing, bs) - -fromBitsDiff :: FromBits a => [Bool] -> ([a] -> [a], [Bool]) -fromBitsDiff bs = case fromBits1 bs of - (Nothing, rs) -> (id , rs) - (Just a , rs) -> case fromBitsDiff rs of - (f, ss) -> ((a:) . f, ss) - -fromBitsDiffN :: FromBits a => Int -> [Bool] -> ([a] -> [a], [Bool]) -fromBitsDiffN n bs - | n > 0 = case fromBits1 bs of - (Nothing, rs) -> (id , rs) - (Just a , rs) -> case fromBitsDiffN (n - 1) rs of - (f, ss) -> ((a:) . f, ss) - | n == 0 = (id, bs) - | n < 0 = error "Invalid count" - | null bs = (id, []) - | otherwise = error "Error" - -stringToBits :: String -> [Bool] -stringToBits [] = [] -stringToBits ('1' :xs) = True :stringToBits xs -stringToBits ('0' :xs) = False:stringToBits xs -stringToBits (' ' :xs) = stringToBits xs -stringToBits ('\n':xs) = stringToBits xs -stringToBits (_ :_ ) = error "Invalid bit" diff --git a/src/HaskellWorks/Data/Bits/ElemFixedBitSize.hs b/src/HaskellWorks/Data/Bits/ElemFixedBitSize.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/ElemFixedBitSize.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. - -module HaskellWorks.Data.Bits.ElemFixedBitSize - ( ElemFixedBitSize(..) - ) where - -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Positioning - -class ElemFixedBitSize v where - type Elem v - elemFixedBitSize :: v -> Count - -instance ElemFixedBitSize [Bool] where - type Elem [Bool] = Bool - elemFixedBitSize _ = 1 - -instance ElemFixedBitSize [Word8] where - type Elem [Word8] = Word8 - elemFixedBitSize _ = 8 - -instance ElemFixedBitSize [Word16] where - type Elem [Word16] = Word16 - elemFixedBitSize _ = 16 - -instance ElemFixedBitSize [Word32] where - type Elem [Word32] = Word32 - elemFixedBitSize _ = 32 - -instance ElemFixedBitSize [Word64] where - type Elem [Word64] = Word64 - elemFixedBitSize _ = 64 - -instance ElemFixedBitSize (DV.Vector Bool) where - type Elem (DV.Vector Bool) = Bool - elemFixedBitSize _ = 1 - -instance ElemFixedBitSize (DV.Vector Word8) where - type Elem (DV.Vector Word8) = Word8 - elemFixedBitSize _ = 8 - -instance ElemFixedBitSize (DV.Vector Word16) where - type Elem (DV.Vector Word16) = Word16 - elemFixedBitSize _ = 16 - -instance ElemFixedBitSize (DV.Vector Word32) where - type Elem (DV.Vector Word32) = Word32 - elemFixedBitSize _ = 32 - -instance ElemFixedBitSize (DV.Vector Word64) where - type Elem (DV.Vector Word64) = Word64 - elemFixedBitSize _ = 64 - -instance ElemFixedBitSize (DVS.Vector Bool) where - type Elem (DVS.Vector Bool) = Bool - elemFixedBitSize _ = 1 - -instance ElemFixedBitSize (DVS.Vector Word8) where - type Elem (DVS.Vector Word8) = Word8 - elemFixedBitSize _ = 8 - -instance ElemFixedBitSize (DVS.Vector Word16) where - type Elem (DVS.Vector Word16) = Word16 - elemFixedBitSize _ = 16 - -instance ElemFixedBitSize (DVS.Vector Word32) where - type Elem (DVS.Vector Word32) = Word32 - elemFixedBitSize _ = 32 - -instance ElemFixedBitSize (DVS.Vector Word64) where - type Elem (DVS.Vector Word64) = Word64 - elemFixedBitSize _ = 64 - diff --git a/src/HaskellWorks/Data/Bits/FixedBitSize.hs b/src/HaskellWorks/Data/Bits/FixedBitSize.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/FixedBitSize.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. - -module HaskellWorks.Data.Bits.FixedBitSize - ( FixedBitSize(..) - ) where - -import Data.Word -import HaskellWorks.Data.Positioning - -class FixedBitSize a where - fixedBitSize :: a -> Count - -instance FixedBitSize Bool where - fixedBitSize _ = 1 - -instance FixedBitSize Word8 where - fixedBitSize _ = 8 - -instance FixedBitSize Word16 where - fixedBitSize _ = 16 - -instance FixedBitSize Word32 where - fixedBitSize _ = 32 - -instance FixedBitSize Word64 where - fixedBitSize _ = 64 diff --git a/src/HaskellWorks/Data/Bits/FromBools.hs b/src/HaskellWorks/Data/Bits/FromBools.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/FromBools.hs +++ /dev/null @@ -1,51 +0,0 @@ --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.FromBools - ( FromBools(..) - ) where - -import Data.Word -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Bits.FixedBitSize - -class FromBools a where - fromBools :: [Bool] -> Maybe (a, [Bool]) - -instance FromBools Word8 where - fromBools [] = Nothing - fromBools xs = go 0 0 xs - where go _ w [] = Just (w, []) - go n w (y:ys) - | n < fixedBitSize w = go (n + 1) (if y then w .|. (1 .<. n) else w) ys - | n < 0 = error "Invalid index" - | otherwise = Just (w, y:ys) - -instance FromBools Word16 where - fromBools [] = Nothing - fromBools xs = go 0 0 xs - where go _ w [] = Just (w, []) - go n w (y:ys) - | n < fixedBitSize w = go (n + 1) (if y then w .|. (1 .<. n) else w) ys - | n < 0 = error "Invalid index" - | otherwise = Just (w, y:ys) - -instance FromBools Word32 where - fromBools [] = Nothing - fromBools xs = go 0 0 xs - where go _ w [] = Just (w, []) - go n w (y:ys) - | n < fixedBitSize w = go (n + 1) (if y then w .|. (1 .<. n) else w) ys - | n < 0 = error "Invalid index" - | otherwise = Just (w, y:ys) - -instance FromBools Word64 where - fromBools [] = Nothing - fromBools xs = go 0 0 xs - where go _ w [] = Just (w, []) - go n w (y:ys) - | n < fixedBitSize w = go (n + 1) (if y then w .|. (1 .<. n) else w) ys - | n < 0 = error "Invalid index" - | otherwise = Just (w, y:ys) diff --git a/src/HaskellWorks/Data/Bits/PopCount.hs b/src/HaskellWorks/Data/Bits/PopCount.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/PopCount.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.PopCount - ( -- * Bit map - PopCount(..) - , module X - ) where - -import HaskellWorks.Data.Bits.PopCount.PopCount0 as X -import HaskellWorks.Data.Bits.PopCount.PopCount1 as X -import HaskellWorks.Data.Positioning - -class PopCount v e where - popCount :: e -> v -> Count diff --git a/src/HaskellWorks/Data/Bits/PopCount/PopCount0.hs b/src/HaskellWorks/Data/Bits/PopCount/PopCount0.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/PopCount/PopCount0.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.PopCount.PopCount0 - ( PopCount0(..) - ) where - -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitLength -import HaskellWorks.Data.Bits.PopCount.PopCount1 -import HaskellWorks.Data.Positioning -import Prelude as P - -class PopCount0 v where - popCount0 :: v -> Count - -instance PopCount0 Bool where - popCount0 True = 0 - popCount0 False = 1 - {-# INLINABLE popCount0 #-} - -instance PopCount0 Word8 where - popCount0 x0 = bitLength x0 - popCount1 x0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 Word16 where - popCount0 x0 = bitLength x0 - popCount1 x0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 Word32 where - popCount0 x0 = bitLength x0 - popCount1 x0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 Word64 where - popCount0 x0 = bitLength x0 - popCount1 x0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 [Bool] where - popCount0 = P.sum . fmap popCount0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 [Word8] where - popCount0 = P.sum . fmap popCount0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 [Word16] where - popCount0 = P.sum . fmap popCount0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 [Word32] where - popCount0 = P.sum . fmap popCount0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 [Word64] where - popCount0 = P.sum . fmap popCount0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DV.Vector Word8) where - popCount0 = DV.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DV.Vector Word16) where - popCount0 = DV.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DV.Vector Word32) where - popCount0 = DV.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DV.Vector Word64) where - popCount0 = DV.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DVS.Vector Word8) where - popCount0 = DVS.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DVS.Vector Word16) where - popCount0 = DVS.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DVS.Vector Word32) where - popCount0 = DVS.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} - -instance PopCount0 (DVS.Vector Word64) where - popCount0 = DVS.foldl (\c -> (c +) . popCount0) 0 - {-# INLINABLE popCount0 #-} diff --git a/src/HaskellWorks/Data/Bits/PopCount/PopCount1.hs b/src/HaskellWorks/Data/Bits/PopCount/PopCount1.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/PopCount/PopCount1.hs +++ /dev/null @@ -1,11 +0,0 @@ - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.PopCount.PopCount1 - ( module X - ) where - -import HaskellWorks.Data.Bits.PopCount.PopCount1.Broadword as X diff --git a/src/HaskellWorks/Data/Bits/PopCount/PopCount1/Broadword.hs b/src/HaskellWorks/Data/Bits/PopCount/PopCount1/Broadword.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/PopCount/PopCount1/Broadword.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.PopCount.PopCount1.Broadword - ( PopCount1(..) - ) where - -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Positioning -import Prelude as P - -class PopCount1 v where - popCount1 :: v -> Count - -instance PopCount1 Bool where - popCount1 True = 1 - popCount1 False = 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word8 where - popCount1 x0 = Count (fromIntegral x3) - where - x1 = x0 - ((x0 .&. 0xaa) .>. 1) - x2 = (x1 .&. 0x33) + ((x1 .>. 2) .&. 0x33) - x3 = (x2 + (x2 .>. 4)) .&. 0x0f - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word16 where - popCount1 x0 = Count (fromIntegral ((x3 * 0x0101) .>. 8)) - where - x1 = x0 - ((x0 .&. 0xaaaa) .>. 1) - x2 = (x1 .&. 0x3333) + ((x1 .>. 2) .&. 0x3333) - x3 = (x2 + (x2 .>. 4)) .&. 0x0f0f - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word32 where - popCount1 x0 = Count (fromIntegral ((x3 * 0x01010101) .>. 24)) - where - x1 = x0 - ((x0 .&. 0xaaaaaaaa) .>. 1) - x2 = (x1 .&. 0x33333333) + ((x1 .>. 2) .&. 0x33333333) - x3 = (x2 + (x2 .>. 4)) .&. 0x0f0f0f0f - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word64 where - popCount1 x0 = Count ((x3 * 0x0101010101010101) .>. 56) - where - x1 = x0 - ((x0 .&. 0xaaaaaaaaaaaaaaaa) .>. 1) - x2 = (x1 .&. 0x3333333333333333) + ((x1 .>. 2) .&. 0x3333333333333333) - x3 = (x2 + (x2 .>. 4)) .&. 0x0f0f0f0f0f0f0f0f - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Bool] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word8] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word16] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word32] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word64] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word8) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word16) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word32) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word64) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word8) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word16) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word32) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word64) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} diff --git a/src/HaskellWorks/Data/Bits/PopCount/PopCount1/GHC.hs b/src/HaskellWorks/Data/Bits/PopCount/PopCount1/GHC.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Bits/PopCount/PopCount1/GHC.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Succinct operations. -module HaskellWorks.Data.Bits.PopCount.PopCount1.GHC - ( PopCount1(..) - ) where - -import qualified Data.Bits as DB -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Positioning -import Prelude as P - -class PopCount1 v where - popCount1 :: v -> Count - -instance PopCount1 Bool where - popCount1 True = 1 - popCount1 False = 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word8 where - popCount1 = fromIntegral . DB.popCount - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word16 where - popCount1 = fromIntegral . DB.popCount - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word32 where - popCount1 = fromIntegral . DB.popCount - {-# INLINABLE popCount1 #-} - -instance PopCount1 Word64 where - popCount1 = fromIntegral . DB.popCount - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Bool] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word8] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word16] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word32] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 [Word64] where - popCount1 = P.sum . fmap popCount1 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word8) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word16) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word32) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DV.Vector Word64) where - popCount1 = DV.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word8) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word16) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word32) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} - -instance PopCount1 (DVS.Vector Word64) where - popCount1 = DVS.foldl (\c -> (c +) . popCount1) 0 - {-# INLINABLE popCount1 #-} diff --git a/src/HaskellWorks/Data/ByteString.hs b/src/HaskellWorks/Data/ByteString.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/ByteString.hs +++ /dev/null @@ -1,11 +0,0 @@ -module HaskellWorks.Data.ByteString - ( chunkedBy - ) where - -import qualified Data.ByteString as BS - -chunkedBy :: Int -> BS.ByteString -> [BS.ByteString] -chunkedBy n bs = if BS.length bs == 0 - then [] - else case BS.splitAt n bs of - (as, zs) -> as : chunkedBy n zs diff --git a/src/HaskellWorks/Data/Conduit/ByteString.hs b/src/HaskellWorks/Data/Conduit/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/ByteString.hs @@ -0,0 +1,32 @@ +module HaskellWorks.Data.Conduit.ByteString + ( rechunk + ) where + +import Control.Monad +import qualified Data.ByteString as BS +import Data.Conduit + +rechunk :: Monad m => Int -> Conduit BS.ByteString m BS.ByteString +rechunk = rechunk' BS.empty + +rechunk' :: Monad m => BS.ByteString -> Int -> Conduit BS.ByteString m BS.ByteString +rechunk' as n | BS.length as >= n = do + yield (BS.take n as) + rechunk' (BS.drop n as) n +rechunk' as n = do + mbss <- slurp (n - BS.length as) + case mbss of + Just bss -> do + let bs = BS.concat (as : bss) + yield (BS.take n bs) + rechunk' (BS.drop n bs) n + Nothing -> unless (BS.null as) $ yield as + +slurp :: Monad m => Int -> ConduitM BS.ByteString BS.ByteString m (Maybe [BS.ByteString]) +slurp = go [] + where go rs n | n > 0 = do + mbs <- await + case mbs of + Just bs -> go (bs : rs) (n - BS.length bs) + Nothing -> if null rs then return Nothing else return (Just (reverse rs)) + go rs _ = if null rs then return Nothing else return (Just (reverse rs)) diff --git a/src/HaskellWorks/Data/Conduit/Json.hs b/src/HaskellWorks/Data/Conduit/Json.hs --- a/src/HaskellWorks/Data/Conduit/Json.hs +++ b/src/HaskellWorks/Data/Conduit/Json.hs @@ -4,29 +4,22 @@ module HaskellWorks.Data.Conduit.Json ( blankedJsonToInterestBits , byteStringToBits - , markerToByteString , blankedJsonToBalancedParens - , jsonToken2Markers - , textToJsonToken + , blankedJsonToBalancedParens2 + , compressWordAsBit , interestingWord8s - , jsonToken2BalancedParens ) where import Control.Monad -import Control.Monad.Trans.Resource (MonadThrow) -import Data.Array.Unboxed as A -import qualified Data.Bits as BITS -import Data.ByteString as BS +import Data.Array.Unboxed as A +import qualified Data.Bits as BITS +import Data.ByteString as BS import Data.Conduit import Data.Int import Data.Word import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Conduit.Json.Words -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Offset -import HaskellWorks.Data.Json.Final.Tokenize -import HaskellWorks.Data.Json.Token -import Prelude as P +import Prelude as P interestingWord8s :: A.UArray Word8 Word8 interestingWord8s = A.array (0, 255) [ @@ -65,64 +58,6 @@ , BS.drop 8 as ) -markerToByteString' :: Monad m => Int64 -> Word8 -> Conduit Int64 m BS.ByteString -markerToByteString' a v = do - mo <- await - case mo of - Just o -> if o < (a + 8) - then markerToByteString' a (BITS.bit (fromIntegral (o - a)) .|. v) - else do - yield $ BS.singleton v - leftover o - markerToByteString' (a + 8) 0 - Nothing -> when (v /= 0) $ yield $ BS.singleton v - -markerToByteString :: Monad m => Conduit Int64 m BS.ByteString -markerToByteString = markerToByteString' 0 0 - -textToJsonToken :: MonadThrow m => Conduit BS.ByteString m (ParseDelta Offset, JsonToken) -textToJsonToken = conduitParser (Offset 0) parseJsonToken - -jsonToken2Markers :: Monad m => Conduit (ParseDelta Offset, JsonToken) m Int64 -jsonToken2Markers = do - mi <- await - case mi of - Just (ParseDelta (Offset start) _, token) -> do - case token of - JsonTokenBraceL -> yield $ fromIntegral start - JsonTokenBraceR -> return () - JsonTokenBracketL -> yield $ fromIntegral start - JsonTokenBracketR -> return () - JsonTokenComma -> return () - JsonTokenColon -> return () - JsonTokenWhitespace -> return () - JsonTokenString _ -> yield $ fromIntegral start - JsonTokenBoolean _ -> yield $ fromIntegral start - JsonTokenNumber _ -> yield $ fromIntegral start - JsonTokenNull -> yield $ fromIntegral start - jsonToken2Markers - Nothing -> return () - -jsonToken2BalancedParens :: Monad m => Conduit (ParseDelta Offset, JsonToken) m Bool -jsonToken2BalancedParens = do - mi <- await - case mi of - Just (ParseDelta (Offset _) _, token) -> do - case token of - JsonTokenBraceL -> yield True - JsonTokenBraceR -> yield False - JsonTokenBracketL -> yield True - JsonTokenBracketR -> yield False - JsonTokenComma -> return () - JsonTokenColon -> return () - JsonTokenWhitespace -> return () - JsonTokenString _ -> yield True >> yield False - JsonTokenBoolean _ -> yield True >> yield False - JsonTokenNumber _ -> yield True >> yield False - JsonTokenNull -> yield True >> yield False - jsonToken2BalancedParens - Nothing -> return () - blankedJsonToBalancedParens :: Monad m => Conduit BS.ByteString m Bool blankedJsonToBalancedParens = do mbs <- await @@ -148,7 +83,55 @@ blankedJsonToBalancedParens' cs Nothing -> return () ------------------------- +compressWordAsBit :: Monad m => Conduit BS.ByteString m BS.ByteString +compressWordAsBit = do + mbs <- await + case mbs of + Just bs -> do + let (cs, _) = BS.unfoldrN (BS.length bs + 7 `div` 8) gen bs + yield cs + Nothing -> return () + where gen :: ByteString -> Maybe (Word8, ByteString) + gen xs = if BS.length xs == 0 + then Nothing + else Just ( BS.foldr (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (padRight 0 8 (BS.take 8 xs)) + , BS.drop 8 xs + ) + +blankedJsonToBalancedParens2 :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedJsonToBalancedParens2 = do + mbs <- await + case mbs of + Just bs -> do + let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) + yield cs + Nothing -> return () + where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString)) + gen (Just True , bs) = Just (wFF, (Nothing, bs)) + gen (Just False , bs) = Just (w00, (Nothing, bs)) + gen (Nothing , bs) = case BS.uncons bs of + Just (c, cs) -> case balancedParensOf c of + MiniN -> gen (Nothing , cs) + MiniT -> Just (wFF, (Nothing , cs)) + MiniF -> Just (w00, (Nothing , cs)) + MiniTF -> Just (wFF, (Just False , cs)) + Nothing -> Nothing + +data MiniBP = MiniN | MiniT | MiniF | MiniTF + +balancedParensOf :: Word8 -> MiniBP +balancedParensOf c = case c of + d | d == wOpenBrace -> MiniT + d | d == wCloseBrace -> MiniF + d | d == wOpenBracket -> MiniT + d | d == wCloseBracket -> MiniF + d | d == wOpenParen -> MiniT + d | d == wCloseParen -> MiniF + d | d == wt -> MiniTF + d | d == wf -> MiniTF + d | d == w1 -> MiniTF + d | d == wn -> MiniTF + _ -> MiniN yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool yieldBitsOfWord8 w = do diff --git a/src/HaskellWorks/Data/Conduit/Json/Words.hs b/src/HaskellWorks/Data/Conduit/Json/Words.hs --- a/src/HaskellWorks/Data/Conduit/Json/Words.hs +++ b/src/HaskellWorks/Data/Conduit/Json/Words.hs @@ -78,6 +78,12 @@ w9 :: Word8 w9 = fromIntegral (ord '9') +w00 :: Word8 +w00 = fromIntegral (ord '0') + +wFF :: Word8 +wFF = fromIntegral (ord '\255') + isLeadingDigit :: Word8 -> Bool isLeadingDigit w = w == wMinus || (w >= w0 && w <= w9) diff --git a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec.hs b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Copyright: 2016 John Ky, 2011 Michael Snoyman, 2010 John Millikin --- License: MIT --- --- Conduits for tokenizing streams. --- --- This code was taken from attoparsec-enumerator and adapted for conduits. -module HaskellWorks.Data.Conduit.Tokenize.Attoparsec - ( -- * Sink - sinkParser - , sinkParserEither - -- * Conduit - , conduitParser - , conduitParserEither - - -- * Types - , ParseError (..) - , ParseDelta (..) - -- * Classes - , AttoparsecInput(..) - , AttoparsecState(..) - ) where - -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Internal diff --git a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Internal.hs b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Internal.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Internal.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Copyright: 2016 John Ky, 2011 Michael Snoyman, 2010 John Millikin --- License: MIT --- --- Consume attoparsec parsers via conduit. --- --- This code was taken from attoparsec-enumerator and adapted for conduits. -module HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Internal - ( -- * Sink - sinkParser - , sinkParserEither - -- * Conduit - , conduitParser - , conduitParserEither - - -- * Types - , ParseError (..) - , ParseDelta (..) - -- * Classes - , AttoparsecInput(..) - , AttoparsecState(..) - ) where - -import Control.Exception (Exception) -import Control.Monad (unless) -import Control.Monad.Trans.Resource (MonadThrow, monadThrow) -import qualified Data.Attoparsec.ByteString -import qualified Data.Attoparsec.Text -import qualified Data.Attoparsec.Types as A -import qualified Data.ByteString as B -import Data.Conduit -import qualified Data.Text as T -import qualified Data.Text.Internal as TI -import Data.Typeable (Typeable) -import Prelude hiding (lines) - --- | The context and message from a 'A.Fail' value. -data ParseError s = ParseError - { errorContexts :: [String] - , errorMessage :: String - , errorPosition :: s - } | DivergentParser - deriving (Show, Typeable) - --- | The before and after state of a single parse in a conduit stream. -data ParseDelta s = ParseDelta - { before :: !s - , after :: !s - } - deriving (Eq, Ord) - --- | A class of types which may be consumed by an Attoparsec parser. -class AttoparsecInput a where - parseA :: A.Parser a b -> a -> A.IResult a b - feedA :: A.IResult a b -> a -> A.IResult a b - empty :: a - isNull :: a -> Bool - notEmpty :: [a] -> [a] - - -- | Return the beginning of the first input with the length of - -- the second input removed. Assumes the second string is shorter - -- than the first. - stripFromEnd :: a -> a -> a - --- | A class of types and states which may be consumed by an Attoparsec parser. -class AttoparsecState a s where - getState :: a -> s - modState :: AttoparsecInput a => a -> s -> s - -instance AttoparsecInput B.ByteString where - parseA = Data.Attoparsec.ByteString.parse - feedA = Data.Attoparsec.ByteString.feed - empty = B.empty - isNull = B.null - notEmpty = filter (not . B.null) - stripFromEnd b1 b2 = B.take (B.length b1 - B.length b2) b1 - -instance AttoparsecInput T.Text where - parseA = Data.Attoparsec.Text.parse - feedA = Data.Attoparsec.Text.feed - empty = T.empty - isNull = T.null - notEmpty = filter (not . T.null) - stripFromEnd (TI.Text arr1 off1 len1) (TI.Text _ _ len2) = - TI.text arr1 off1 (len1 - len2) - --- | Convert an Attoparsec 'A.Parser' into a 'Sink'. The parser will --- be streamed bytes until it returns 'A.Done' or 'A.Fail'. --- --- If parsing fails, a 'ParseError' will be thrown with 'monadThrow'. --- --- Since 0.5.0 -sinkParser :: (AttoparsecInput a, AttoparsecState a s, MonadThrow m, Exception (ParseError s)) => s -> A.Parser a b -> Consumer a m b -sinkParser s = fmap snd . sinkParserPosErr s - --- | Same as 'sinkParser', but we return an 'Either' type instead --- of raising an exception. --- --- Since 1.1.5 -sinkParserEither :: (AttoparsecInput a, AttoparsecState a s, Monad m) => s -> A.Parser a b -> Consumer a m (Either (ParseError s) b) -sinkParserEither s = (fmap.fmap) snd . sinkParserPos s - --- | Consume a stream of parsed tokens, returning both the token and --- the position it appears at. This function will raise a 'ParseError' --- on bad input. --- --- Since 0.5.0 -conduitParser :: (AttoparsecInput a, AttoparsecState a s, MonadThrow m, Exception (ParseError s)) => s -> A.Parser a b -> Conduit a m (ParseDelta s, b) -conduitParser s parser = conduit s - where - conduit !pos = await >>= maybe (return ()) go - where - go x = do - leftover x - (!pos', !res) <- sinkParserPosErr pos parser - yield (ParseDelta pos pos', res) - conduit pos' -{-# INLINABLE conduitParser #-} - --- | Same as 'conduitParser', but we return an 'Either' type instead --- of raising an exception. -conduitParserEither - :: (Monad m, AttoparsecInput a, AttoparsecState a s) - => s - -> A.Parser a b - -> Conduit a m (Either (ParseError s) (ParseDelta s, b)) -conduitParserEither s parser = conduit s - where - conduit !pos = await >>= maybe (return ()) go - where - go x = do - leftover x - eres <- sinkParserPos pos parser - case eres of - Left e -> yield $ Left e - Right (!pos', !res) -> do - yield $! Right (ParseDelta pos pos', res) - conduit pos' -{-# INLINABLE conduitParserEither #-} - -sinkParserPosErr - :: (AttoparsecInput a, AttoparsecState a s, MonadThrow m, Exception (ParseError s)) - => s - -> A.Parser a b - -> Consumer a m (s, b) -sinkParserPosErr s p = sinkParserPos s p >>= f - where - f (Left e) = monadThrow e - f (Right a) = return a -{-# INLINABLE sinkParserPosErr #-} - -sinkParserPos - :: (AttoparsecInput a, AttoparsecState a s, Monad m) - => s - -> A.Parser a b - -> Consumer a m (Either (ParseError s) (s, b)) -sinkParserPos s p = sink empty s (parseA p) - where - -- sink :: a -> s -> (a -> A.IResult a b) -> Consumer a m (Either (ParseError s) (s, b)) - sink prev pos parser = await >>= maybe close push - where - push c - | isNull c = sink prev pos parser - | otherwise = go False c $ parser c - - close = go True prev (feedA (parser empty) empty) - - go end c (A.Done lo x) = do - let pos' - | end = pos - | otherwise = modState prev pos - y = stripFromEnd c lo - pos'' = modState y pos' - unless (isNull lo) $ leftover lo - pos'' `seq` return $! Right (pos'', x) - go end c (A.Fail rest contexts msg) = - let x = stripFromEnd c rest - pos' - | end = pos - | otherwise = modState prev pos - pos'' = modState x pos' - in pos'' `seq` return $! Left (ParseError contexts msg pos'') - go end c (A.Partial parser') - | end = return $! Left DivergentParser - | otherwise = - pos' `seq` sink c pos' parser' - where - pos' = modState prev pos - -{-# INLINABLE sinkParserPos #-} diff --git a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumn.hs b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumn.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumn.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Copyright: 2016 John Ky, 2011 Michael Snoyman, 2010 John Millikin --- License: MIT --- --- Conduits for tokenizing streams. --- --- This code was taken from attoparsec-enumerator and adapted for conduits. -module HaskellWorks.Data.Conduit.Tokenize.Attoparsec.LineColumn - ( Position (..) - ) where - -import Control.Exception (Exception) -import Control.Monad.Trans.Resource (MonadThrow) -import qualified Data.Attoparsec.Types as A -import qualified Data.ByteString as B -import Data.Conduit -import qualified Data.Text as T -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Internal -import Prelude hiding (lines) - -data Position = Position - { posLine :: {-# UNPACK #-} !Int - , posCol :: {-# UNPACK #-} !Int - } - deriving (Eq, Ord) - -instance Show Position where - show (Position l c) = show l ++ ':' : show c - -instance Exception (ParseError Position) - -instance Show (ParseDelta Position) where - show (ParseDelta s e) = show s ++ '-' : show e - -instance AttoparsecState B.ByteString Position where - getState = B.foldl' f (Position 0 0) - where - f (Position l c) ch | ch == 10 = Position (l + 1) 0 - | otherwise = Position l (c + 1) - modState x (Position lines cols) = - lines' `seq` cols' `seq` Position lines' cols' - where - Position dlines dcols = getState x - lines' = lines + dlines - cols' = (if dlines > 0 then 1 else cols) + dcols - -instance AttoparsecState T.Text Position where - getState = T.foldl' f (Position 0 0) - where - f (Position l c) ch | ch == '\n' = Position (l + 1) 0 - | otherwise = Position l (c + 1) - modState x (Position lines cols) = - lines' `seq` cols' `seq` Position lines' cols' - where - Position dlines dcols = getState x - lines' = lines + dlines - cols' = (if dlines > 0 then 1 else cols) + dcols - -{-# SPECIALIZE conduitParser - :: MonadThrow m - => Position - -> A.Parser T.Text b - -> Conduit T.Text m (ParseDelta Position, b) #-} - -{-# SPECIALIZE conduitParser - :: MonadThrow m - => Position - -> A.Parser B.ByteString b - -> Conduit B.ByteString m (ParseDelta Position, b) #-} - -{-# SPECIALIZE conduitParserEither - :: Monad m - => Position - -> A.Parser T.Text b - -> Conduit T.Text m (Either (ParseError Position) (ParseDelta Position, b)) #-} - -{-# SPECIALIZE conduitParserEither - :: Monad m - => Position - -> A.Parser B.ByteString b - -> Conduit B.ByteString m (Either (ParseError Position) (ParseDelta Position, b)) #-} diff --git a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Offset.hs b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Offset.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Offset.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | --- Copyright: 2016 John Ky, 2011 Michael Snoyman, 2010 John Millikin --- License: MIT --- --- Conduits for tokenizing streams. --- --- This code was taken from attoparsec-enumerator and adapted for conduits. -module HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Offset - ( Offset (..) - ) where - -import Control.Exception (Exception) -import Control.Monad.Trans.Resource (MonadThrow) -import qualified Data.Attoparsec.Types as A -import qualified Data.ByteString as B -import Data.Conduit -import Data.Int -import qualified Data.Text as T -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Internal -import Prelude hiding (lines) - -data Offset = Offset - { pos :: {-# UNPACK #-} !Int64 - } - deriving (Eq, Ord) - -instance Show Offset where - show (Offset c) = show c - -instance Exception (ParseError Offset) - -instance Show (ParseDelta Offset) where - show (ParseDelta s e) = show s ++ '-' : show e - -instance AttoparsecState B.ByteString Offset where - getState = B.foldl' f (Offset 0) - where - f (Offset c) _ = Offset (c + 1) - modState x (Offset cols) = cols' `seq` Offset cols' - where - Offset dcols = getState x - cols' = cols + dcols - -instance AttoparsecState T.Text Offset where - getState = T.foldl' f (Offset 0) - where - f (Offset c) _ = Offset (c + 1) - modState x (Offset cols) = - cols' `seq` Offset cols' - where - Offset dcols = getState x - cols' = cols + dcols - -{-# SPECIALIZE conduitParser - :: MonadThrow m - => Offset - -> A.Parser T.Text b - -> Conduit T.Text m (ParseDelta Offset, b) #-} - -{-# SPECIALIZE conduitParser - :: MonadThrow m - => Offset - -> A.Parser B.ByteString b - -> Conduit B.ByteString m (ParseDelta Offset, b) #-} - -{-# SPECIALIZE conduitParserEither - :: Monad m - => Offset - -> A.Parser T.Text b - -> Conduit T.Text m (Either (ParseError Offset) (ParseDelta Offset, b)) #-} - -{-# SPECIALIZE conduitParserEither - :: Monad m - => Offset - -> A.Parser B.ByteString b - -> Conduit B.ByteString m (Either (ParseError Offset) (ParseDelta Offset, b)) #-} diff --git a/src/HaskellWorks/Data/FromByteString.hs b/src/HaskellWorks/Data/FromByteString.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/FromByteString.hs +++ /dev/null @@ -1,8 +0,0 @@ -module HaskellWorks.Data.FromByteString - ( FromByteString(..) - ) where - -import Data.ByteString.Internal - -class FromByteString a where - fromByteString :: ByteString -> a diff --git a/src/HaskellWorks/Data/FromForeignRegion.hs b/src/HaskellWorks/Data/FromForeignRegion.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/FromForeignRegion.hs +++ /dev/null @@ -1,7 +0,0 @@ -module HaskellWorks.Data.FromForeignRegion where - -import Data.Word -import Foreign.ForeignPtr - -class FromForeignRegion a where - fromForeignRegion :: (ForeignPtr Word8, Int, Int) -> a diff --git a/src/HaskellWorks/Data/Json/Final/Tokenize.hs b/src/HaskellWorks/Data/Json/Final/Tokenize.hs --- a/src/HaskellWorks/Data/Json/Final/Tokenize.hs +++ b/src/HaskellWorks/Data/Json/Final/Tokenize.hs @@ -2,5 +2,4 @@ ( parseJsonToken ) where -import HaskellWorks.Data.Attoparsec.Final.Parser.ByteString () import HaskellWorks.Data.Json.Final.Tokenize.Internal diff --git a/src/HaskellWorks/Data/Json/Succinct.hs b/src/HaskellWorks/Data/Json/Succinct.hs --- a/src/HaskellWorks/Data/Json/Succinct.hs +++ b/src/HaskellWorks/Data/Json/Succinct.hs @@ -2,5 +2,4 @@ ( module X ) where -import HaskellWorks.Data.Json.Succinct.Cursor as X -import HaskellWorks.Data.Json.Succinct.Transform as X +import HaskellWorks.Data.Json.Succinct.Cursor as X diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs @@ -8,9 +8,11 @@ , getJsonBalancedParens ) where +import Control.Applicative +import qualified Data.ByteString as BS +import Data.Conduit import qualified Data.Vector.Storable as DVS import Data.Word -import HaskellWorks.Data.Bits.FromBools import HaskellWorks.Data.Conduit.Json import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson @@ -21,14 +23,29 @@ getJsonBalancedParens :: JsonBalancedParens a -> a getJsonBalancedParens (JsonBalancedParens a) = a +genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString) +genBitWordsForever bs = BS.uncons bs <|> Just (0, bs) +{-# INLINABLE genBitWordsForever #-} + +instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens [Bool])) where + fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (runListConduit blankedJsonToBalancedParens bj)) + instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where - fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where - fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where - fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where - fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs @@ -16,6 +16,7 @@ import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Conduit.Json import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 @@ -33,11 +34,14 @@ genInterestForever :: ByteString -> Maybe (Word8, ByteString) genInterestForever bs = BS.uncons bs <|> Just (0, bs) +instance FromBlankedJson (JsonInterestBits (BitShown [Bool])) where + fromBlankedJson = JsonInterestBits . fromByteString . BS.concat . runListConduit blankedJsonToInterestBits . getBlankedJson + instance FromBlankedJson (JsonInterestBits (BitShown BS.ByteString)) where - fromBlankedJson (BlankedJson bj) = JsonInterestBits (BitShown (BS.unfoldr genInterest (blankedJsonBssToInterestBitsBs bj))) + fromBlankedJson = JsonInterestBits . BitShown . BS.unfoldr genInterest . blankedJsonBssToInterestBitsBs . getBlankedJson instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word8))) where - fromBlankedJson (BlankedJson bj) = JsonInterestBits (BitShown (DVS.unfoldr genInterest (blankedJsonBssToInterestBitsBs bj))) + fromBlankedJson = JsonInterestBits . BitShown . DVS.unfoldr genInterest . blankedJsonBssToInterestBitsBs . getBlankedJson instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word16))) where fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs @@ -20,7 +20,6 @@ import HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson import HaskellWorks.Data.Json.Succinct.Cursor.InterestBits -import HaskellWorks.Data.Json.Succinct.Transform import HaskellWorks.Data.Positioning import HaskellWorks.Data.Succinct.BalancedParens as BP import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 @@ -49,11 +48,11 @@ fromString s = JsonCursor { cursorText = s , cursorRank = 1 - , balancedParens = SimpleBalancedParens (jsonToInterestBalancedParens [bs]) - , interests = BitShown interests' + , interests = getJsonInterestBits (fromBlankedJson blankedJson) + , balancedParens = getJsonBalancedParens (fromBlankedJson blankedJson) } - where bs = BSC.pack s :: BS.ByteString - interests' = jsonToInterestBits [bs] + where blankedJson :: BlankedJson + blankedJson = fromByteString (BSC.pack s) instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) where fromString = fromByteString . BSC.pack diff --git a/src/HaskellWorks/Data/Json/Succinct/Transform.hs b/src/HaskellWorks/Data/Json/Succinct/Transform.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/Transform.hs +++ /dev/null @@ -1,18 +0,0 @@ -module HaskellWorks.Data.Json.Succinct.Transform - ( jsonToInterestBits - , jsonToInterestBalancedParens - ) where - -import qualified Data.ByteString as BS -import Data.Conduit -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Conduit.Json -import HaskellWorks.Data.Conduit.Json.Blank -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.FromByteString - -jsonToInterestBits :: [BS.ByteString] -> [Bool] -jsonToInterestBits json = bitShown (fromByteString (BS.concat $ runListConduit (blankJson =$= blankedJsonToInterestBits) json)) - -jsonToInterestBalancedParens :: [BS.ByteString] -> [Bool] -jsonToInterestBalancedParens = runListConduit (blankJson =$= blankedJsonToBalancedParens) diff --git a/src/HaskellWorks/Data/Positioning.hs b/src/HaskellWorks/Data/Positioning.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Positioning.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module HaskellWorks.Data.Positioning - ( Count(..) - , Position(..) - , lastPositionOf - , toCount - , toPosition - ) where - -import Data.Int -import Data.Word -import System.Random - -newtype Count = Count { getCount :: Word64 } - deriving (Eq, Num, Ord, Enum, Integral, Real, Random) - -instance Show Count where - show (Count w64) = show w64 - -newtype Position = Position { getPosition :: Int64 } - deriving (Eq, Num, Ord, Enum, Real, Integral) - -instance Show Position where - show (Position n) = show n - -toPosition :: Count -> Position -toPosition (Count n) = Position (fromIntegral n) - -toCount :: Position -> Count -toCount (Position n) = Count (fromIntegral n) - -lastPositionOf :: Count -> Position -lastPositionOf (Count c) = Position (fromIntegral c - 1) diff --git a/src/HaskellWorks/Data/Search.hs b/src/HaskellWorks/Data/Search.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Search.hs +++ /dev/null @@ -1,12 +0,0 @@ -module HaskellWorks.Data.Search - ( binarySearch - ) where - -binarySearch :: (Ord a, Integral n) => a -> (n -> a) -> n -> n -> n -binarySearch w f p q = if p + 1 >= q - then p - else let m = p + q `div` 2 in - if w <= f m - then binarySearch w f p m - else binarySearch w f m q -{-# INLINABLE binarySearch #-} diff --git a/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs b/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs --- a/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs +++ b/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs @@ -28,18 +28,22 @@ instance Functor SimpleBalancedParens where fmap f (SimpleBalancedParens a) = SimpleBalancedParens (f a) + {-# INLINABLE fmap #-} instance BitShow a => Show (SimpleBalancedParens a) where show = bitShow closeAt :: TestBit a => a -> Count -> Bool -closeAt v c = not (v .?. lastPositionOf c) +closeAt v c = not (v .?. toPosition (c - 1)) +{-# INLINABLE closeAt #-} openAt :: TestBit a => a -> Count -> Bool -openAt v c = v .?. lastPositionOf c +openAt v c = v .?. toPosition (c - 1) +{-# INLINABLE openAt #-} require :: Bool -> String -> a -> a require p msg v = if p then v else error msg +{-# INLINABLE require #-} findOpen' :: (BitLength a, TestBit a) => Count -> SimpleBalancedParens a -> Count -> Count findOpen' c v p = @@ -49,6 +53,7 @@ then p else findOpen' (c - 1) v (p - 1) else findOpen' (c + 1) v (p - 1) +{-# INLINABLE findOpen' #-} findClose' :: (BitLength a, TestBit a) => Count -> SimpleBalancedParens a -> Count -> Count findClose' c v p = @@ -58,48 +63,76 @@ then p else findClose' (c + 1) v (p + 1) else findClose' (c - 1) v (p + 1) +{-# INLINABLE findClose' #-} instance BalancedParens (SimpleBalancedParens [Bool]) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens (DVS.Vector Word8)) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens (DVS.Vector Word16)) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens (DVS.Vector Word32)) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens (DVS.Vector Word64)) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens Word8) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens Word16) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens Word32) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} instance BalancedParens (SimpleBalancedParens Word64) where findOpen v p = if v `openAt` p then p else findOpen' (Count 0) v (p - 1) findClose v p = if v `closeAt` p then p else findClose' (Count 0) v (p + 1) enclose = findOpen' (Count 1) + {-# INLINABLE findOpen #-} + {-# INLINABLE findClose #-} + {-# INLINABLE enclose #-} diff --git a/src/HaskellWorks/Data/Vector/BoxedVectorLike.hs b/src/HaskellWorks/Data/Vector/BoxedVectorLike.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Vector/BoxedVectorLike.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module HaskellWorks.Data.Vector.BoxedVectorLike - ( BoxedVectorLike(..) - ) where - -import qualified Data.Vector as DV -import Data.Word -import Foreign.Storable - -class BoxedVectorLike v e where - bImap :: (Int -> a -> b) -> v a -> v b - bMap :: (a -> b) -> v a -> v b - bUnfoldr :: (Storable a) => (b -> Maybe (a, b)) -> b -> v a - bUnfoldrN :: (Storable a) => Int -> (b -> Maybe (a, b)) -> b -> v a - -instance BoxedVectorLike DV.Vector Word8 where - bImap = DV.imap - {-# INLINABLE bImap #-} - - bMap = DV.map - {-# INLINABLE bMap #-} - - bUnfoldr = DV.unfoldr - {-# INLINABLE bUnfoldr #-} - - bUnfoldrN = DV.unfoldrN - {-# INLINABLE bUnfoldrN #-} - -instance BoxedVectorLike DV.Vector Word16 where - bImap = DV.imap - {-# INLINABLE bImap #-} - - bMap = DV.map - {-# INLINABLE bMap #-} - - bUnfoldr = DV.unfoldr - {-# INLINABLE bUnfoldr #-} - - bUnfoldrN = DV.unfoldrN - {-# INLINABLE bUnfoldrN #-} - -instance BoxedVectorLike DV.Vector Word32 where - bImap = DV.imap - {-# INLINABLE bImap #-} - - bMap = DV.map - {-# INLINABLE bMap #-} - - bUnfoldr = DV.unfoldr - {-# INLINABLE bUnfoldr #-} - - bUnfoldrN = DV.unfoldrN - {-# INLINABLE bUnfoldrN #-} - -instance BoxedVectorLike DV.Vector Word64 where - bImap = DV.imap - {-# INLINABLE bImap #-} - - bMap = DV.map - {-# INLINABLE bMap #-} - - bUnfoldr = DV.unfoldr - {-# INLINABLE bUnfoldr #-} - - bUnfoldrN = DV.unfoldrN - {-# INLINABLE bUnfoldrN #-} diff --git a/src/HaskellWorks/Data/Vector/Storable/ByteString.hs b/src/HaskellWorks/Data/Vector/Storable/ByteString.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Vector/Storable/ByteString.hs +++ /dev/null @@ -1,38 +0,0 @@ --- from spool - --- | Convert between @ByteString@ and @Vector.Storable@ --- without copying. -module HaskellWorks.Data.Vector.Storable.ByteString - ( -- | See also the caveats mentioned in the package's - -- top-level documentation. - byteStringToVector - , vectorToByteString - ) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import qualified Data.Vector.Storable as V - -import Foreign.ForeignPtr -import Foreign.Storable - -sizeOfElem :: (Storable a) => V.Vector a -> Int -sizeOfElem vec = sizeOf (undefined `asTypeOf` V.head vec) - --- | Convert a @'BS.ByteString'@ to a @'V.Vector'@. --- --- This function can produce @'Vector'@s which do not obey --- architectural alignment requirements. On @x86@ this should --- not be an issue. -byteStringToVector :: (Storable a) => BS.ByteString -> V.Vector a -byteStringToVector bs = vec where - vec = V.unsafeFromForeignPtr (castForeignPtr fptr) (scale off) (scale len) - (fptr, off, len) = BS.toForeignPtr bs - scale = (`div` sizeOfElem vec) - --- | Convert a @'V.Vector'@ to a @'BS.ByteString'@. -vectorToByteString :: (Storable a) => V.Vector a -> BS.ByteString -vectorToByteString vec - = BS.fromForeignPtr (castForeignPtr fptr) (scale off) (scale len) where - (fptr, off, len) = V.unsafeToForeignPtr vec - scale = (* sizeOfElem vec) diff --git a/src/HaskellWorks/Data/Vector/StorableVectorLike.hs b/src/HaskellWorks/Data/Vector/StorableVectorLike.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Vector/StorableVectorLike.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module HaskellWorks.Data.Vector.StorableVectorLike - ( StorableVectorLike(..) - ) where - -import qualified Data.Vector.Storable as DVS -import Data.Word -import Foreign.Storable - -class StorableVectorLike v e where - sImap :: (Storable a, Storable b) => (Int -> a -> b) -> v a -> v b - sMap :: (Storable a, Storable b) => (a -> b) -> v a -> v b - sUnfoldr :: (Storable a) => (b -> Maybe (a, b)) -> b -> v a - sUnfoldrN :: (Storable a) => Int -> (b -> Maybe (a, b)) -> b -> v a - -instance StorableVectorLike DVS.Vector Word8 where - sImap = DVS.imap - {-# INLINABLE sImap #-} - - sMap = DVS.map - {-# INLINABLE sMap #-} - - sUnfoldr = DVS.unfoldr - {-# INLINABLE sUnfoldr #-} - - sUnfoldrN = DVS.unfoldrN - {-# INLINABLE sUnfoldrN #-} - -instance StorableVectorLike DVS.Vector Word16 where - sImap = DVS.imap - {-# INLINABLE sImap #-} - - sMap = DVS.map - {-# INLINABLE sMap #-} - - sUnfoldr = DVS.unfoldr - {-# INLINABLE sUnfoldr #-} - - sUnfoldrN = DVS.unfoldrN - {-# INLINABLE sUnfoldrN #-} - -instance StorableVectorLike DVS.Vector Word32 where - sImap = DVS.imap - {-# INLINABLE sImap #-} - - sMap = DVS.map - {-# INLINABLE sMap #-} - - sUnfoldr = DVS.unfoldr - {-# INLINABLE sUnfoldr #-} - - sUnfoldrN = DVS.unfoldrN - {-# INLINABLE sUnfoldrN #-} - -instance StorableVectorLike DVS.Vector Word64 where - sImap = DVS.imap - {-# INLINABLE sImap #-} - - sMap = DVS.map - {-# INLINABLE sMap #-} - - sUnfoldr = DVS.unfoldr - {-# INLINABLE sUnfoldr #-} - - sUnfoldrN = DVS.unfoldrN - {-# INLINABLE sUnfoldrN #-} diff --git a/src/HaskellWorks/Data/Vector/VectorLike.hs b/src/HaskellWorks/Data/Vector/VectorLike.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Vector/VectorLike.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module HaskellWorks.Data.Vector.VectorLike - ( VectorLike(..) - ) where - -import qualified Data.ByteString as BS -import qualified Data.Vector as DV -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Positioning - -class VectorLike v where - type Elem v - - vToList :: v -> [Elem v] - vFromList :: [Elem v] -> v - (!!!) :: v -> Position -> Elem v - vConcat :: [v] -> v - vEmpty :: v - vFilter :: (Elem v -> Bool) -> v -> v - vGenerate :: Int -> (Int -> Elem v) -> v - vLength :: v -> Count - vSnoc :: v -> Elem v -> v - vDrop :: Count -> v -> v - vTake :: Count -> v -> v - vIndex :: v -> Position -> Elem v - vSlice :: Position -> Position -> v -> v - - -instance VectorLike String where - type Elem String = Char - - vToList = id - {-# INLINABLE vToList #-} - - vFromList = id - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v !! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = concat - {-# INLINABLE vConcat #-} - - vEmpty = "" - {-# INLINABLE vEmpty #-} - - vFilter = filter - {-# INLINABLE vFilter #-} - - vGenerate n f = f `fmap` [0 .. (n - 1)] - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . length - {-# INLINABLE vLength #-} - - vSnoc v c = v ++ [c] - {-# INLINABLE vSnoc #-} - - vDrop = drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = v !! fromIntegral i - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = take (fromIntegral j) . drop (fromIntegral i) - {-# INLINABLE vSlice #-} - -instance VectorLike BS.ByteString where - type Elem BS.ByteString = Word8 - - vToList = BS.unpack - {-# INLINABLE vToList #-} - - vFromList = BS.pack - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v `BS.index` fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = BS.concat - {-# INLINABLE vConcat #-} - - vEmpty = BS.empty - {-# INLINABLE vEmpty #-} - - vFilter = BS.filter - {-# INLINABLE vFilter #-} - - vGenerate n f = fst (BS.unfoldrN n go 0) - where go i = if i /= n then Just (f i, i + 1) else Nothing - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . BS.length - {-# INLINABLE vLength #-} - - vSnoc = BS.snoc - {-# INLINABLE vSnoc #-} - - vDrop = BS.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = BS.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = BS.index v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = BS.take (fromIntegral j) . BS.drop (fromIntegral i) - {-# INLINABLE vSlice #-} - -instance VectorLike (DV.Vector Word8) where - type Elem (DV.Vector Word8) = Word8 - - vToList = DV.toList - {-# INLINABLE vToList #-} - - vFromList = DV.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DV.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DV.concat - {-# INLINABLE vConcat #-} - - vEmpty = DV.empty - {-# INLINABLE vEmpty #-} - - vFilter = DV.filter - {-# INLINABLE vFilter #-} - - vGenerate = DV.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DV.length - {-# INLINABLE vLength #-} - - vSnoc = DV.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DV.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DV.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DV.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DV.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - - -instance VectorLike (DV.Vector Word16) where - type Elem (DV.Vector Word16) = Word16 - - vToList = DV.toList - {-# INLINABLE vToList #-} - - vFromList = DV.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DV.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DV.concat - {-# INLINABLE vConcat #-} - - vEmpty = DV.empty - {-# INLINABLE vEmpty #-} - - vFilter = DV.filter - {-# INLINABLE vFilter #-} - - vGenerate = DV.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DV.length - {-# INLINABLE vLength #-} - - vSnoc = DV.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DV.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DV.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DV.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DV.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - -instance VectorLike (DV.Vector Word32) where - type Elem (DV.Vector Word32) = Word32 - - vToList = DV.toList - {-# INLINABLE vToList #-} - - vFromList = DV.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DV.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DV.concat - {-# INLINABLE vConcat #-} - - vEmpty = DV.empty - {-# INLINABLE vEmpty #-} - - vFilter = DV.filter - {-# INLINABLE vFilter #-} - - vGenerate = DV.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DV.length - {-# INLINABLE vLength #-} - - vSnoc = DV.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DV.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DV.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DV.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DV.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - -instance VectorLike (DV.Vector Word64) where - type Elem (DV.Vector Word64) = Word64 - - vToList = DV.toList - {-# INLINABLE vToList #-} - - vFromList = DV.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DV.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DV.concat - {-# INLINABLE vConcat #-} - - vEmpty = DV.empty - {-# INLINABLE vEmpty #-} - - vFilter = DV.filter - {-# INLINABLE vFilter #-} - - vGenerate = DV.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DV.length - {-# INLINABLE vLength #-} - - vSnoc = DV.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DV.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DV.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DV.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DV.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - -instance VectorLike (DVS.Vector Word8) where - type Elem (DVS.Vector Word8) = Word8 - - vToList = DVS.toList - {-# INLINABLE vToList #-} - - vFromList = DVS.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DVS.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DVS.concat - {-# INLINABLE vConcat #-} - - vEmpty = DVS.empty - {-# INLINABLE vEmpty #-} - - vFilter = DVS.filter - {-# INLINABLE vFilter #-} - - vGenerate = DVS.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DVS.length - {-# INLINABLE vLength #-} - - vSnoc = DVS.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DVS.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DVS.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DVS.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DVS.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - -instance VectorLike (DVS.Vector Word16) where - type Elem (DVS.Vector Word16) = Word16 - - vToList = DVS.toList - {-# INLINABLE vToList #-} - - vFromList = DVS.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DVS.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DVS.concat - {-# INLINABLE vConcat #-} - - vEmpty = DVS.empty - {-# INLINABLE vEmpty #-} - - vFilter = DVS.filter - {-# INLINABLE vFilter #-} - - vGenerate = DVS.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DVS.length - {-# INLINABLE vLength #-} - - vSnoc = DVS.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DVS.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DVS.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DVS.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DVS.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - -instance VectorLike (DVS.Vector Word32) where - type Elem (DVS.Vector Word32) = Word32 - - vToList = DVS.toList - {-# INLINABLE vToList #-} - - vFromList = DVS.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DVS.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DVS.concat - {-# INLINABLE vConcat #-} - - vEmpty = DVS.empty - {-# INLINABLE vEmpty #-} - - vFilter = DVS.filter - {-# INLINABLE vFilter #-} - - vGenerate = DVS.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DVS.length - {-# INLINABLE vLength #-} - - vSnoc = DVS.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DVS.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DVS.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DVS.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DVS.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} - -instance VectorLike (DVS.Vector Word64) where - type Elem (DVS.Vector Word64) = Word64 - - vToList = DVS.toList - {-# INLINABLE vToList #-} - - vFromList = DVS.fromList - {-# INLINABLE vFromList #-} - - (!!!) v (Position i) = v DVS.! fromIntegral i - {-# INLINABLE (!!!) #-} - - vConcat = DVS.concat - {-# INLINABLE vConcat #-} - - vEmpty = DVS.empty - {-# INLINABLE vEmpty #-} - - vFilter = DVS.filter - {-# INLINABLE vFilter #-} - - vGenerate = DVS.generate - {-# INLINABLE vGenerate #-} - - vLength = Count . fromIntegral . DVS.length - {-# INLINABLE vLength #-} - - vSnoc = DVS.snoc - {-# INLINABLE vSnoc #-} - - vDrop = DVS.drop . fromIntegral - {-# INLINABLE vDrop #-} - - vTake = DVS.take . fromIntegral - {-# INLINABLE vTake #-} - - vIndex v (Position i) = DVS.unsafeIndex v (fromIntegral i) - {-# INLINABLE vIndex #-} - - vSlice (Position i) (Position j) = DVS.unsafeSlice (fromIntegral i) (fromIntegral j) - {-# INLINABLE vSlice #-} diff --git a/src/HaskellWorks/Data/Word.hs b/src/HaskellWorks/Data/Word.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Word.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module HaskellWorks.Data.Word where - -import Data.Word -import HaskellWorks.Data.Bits.BitLength -import HaskellWorks.Data.Bits.BitWise - -class WordConcat a where - type DoubleWords a - leConcat :: a -> a -> DoubleWords a - -class WordSplit a where - type HalfWords a - leSplit :: a -> (HalfWords a, HalfWords a) - -instance WordConcat Word8 where - type DoubleWords Word8 = Word16 - leConcat a b = (fromIntegral b .<. bitLength a) .|. fromIntegral a - -instance WordConcat Word16 where - type DoubleWords Word16 = Word32 - leConcat a b = (fromIntegral b .<. bitLength a) .|. fromIntegral a - -instance WordConcat Word32 where - type DoubleWords Word32 = Word64 - leConcat a b = (fromIntegral b .<. bitLength a) .|. fromIntegral a - -instance WordSplit Word64 where - type HalfWords Word64 = Word32 - leSplit a = (fromIntegral a, fromIntegral (a .>. 32)) - -instance WordSplit Word32 where - type HalfWords Word32 = Word16 - leSplit a = (fromIntegral a, fromIntegral (a .>. 16)) - -instance WordSplit Word16 where - type HalfWords Word16 = Word8 - leSplit a = (fromIntegral a, fromIntegral (a .>. 8)) diff --git a/src/HaskellWorks/Function.hs b/src/HaskellWorks/Function.hs deleted file mode 100644 --- a/src/HaskellWorks/Function.hs +++ /dev/null @@ -1,6 +0,0 @@ -module HaskellWorks.Function - ( applyN - ) where - -applyN :: (a -> a) -> Int -> a -> a -applyN f n = foldl (.) id (replicate (fromIntegral n) f) diff --git a/test/HaskellWorks/Data/Bits/FromBoolsSpec.hs b/test/HaskellWorks/Data/Bits/FromBoolsSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Bits/FromBoolsSpec.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HaskellWorks.Data.Bits.FromBoolsSpec (spec) where - -import Data.Word -import HaskellWorks.Data.Bits.FromBools -import Test.Hspec - -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} - -spec :: Spec -spec = describe "HaskellWorks.Data.Bits.FromBoolsSpec" $ do - describe "for Word8" $ do - it "fromBool works for 0 bits" $ do - let result = fromBools [] :: Maybe (Word8, [Bool]) - result `shouldBe` Nothing - it "fromBool works for 4 bits" $ do - let result = fromBools [ True, False, True, False] :: Maybe (Word8, [Bool]) - result `shouldBe` Just (0x5, []) - it "fromBool works for 8 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - ] :: Maybe (Word8, [Bool]) - result `shouldBe` Just (0x55, []) - it "fromBool works for 12 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word8, [Bool]) - result `shouldBe` Just (0x55, [True, False, True, False]) - describe "for Word16" $ do - it "fromBool works for 0 bits" $ do - let result = fromBools [] :: Maybe (Word16, [Bool]) - result `shouldBe` Nothing - it "fromBool works for 4 bits" $ do - let result = fromBools [ True, False, True, False - ] :: Maybe (Word16, [Bool]) - result `shouldBe` Just (0x5, []) - it "fromBool works for 8 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - ] :: Maybe (Word16, [Bool]) - result `shouldBe` Just (0x55, []) - it "fromBool works for 12 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word16, [Bool]) - result `shouldBe` Just (0x555, []) - it "fromBool works for 16 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - ] :: Maybe (Word16, [Bool]) - result `shouldBe` Just (0x5555, []) - it "fromBool works for 20 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word16, [Bool]) - result `shouldBe` Just (0x5555, [True, False, True, False]) - describe "for Word32" $ do - it "fromBool works for 0 bits" $ do - let result = fromBools [] :: Maybe (Word32, [Bool]) - result `shouldBe` Nothing - it "fromBool works for 4 bits" $ do - let result = fromBools [ True, False, True, False - ] :: Maybe (Word32, [Bool]) - result `shouldBe` Just (0x5, []) - it "fromBool works for 8 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - ] :: Maybe (Word32, [Bool]) - result `shouldBe` Just (0x55, []) - it "fromBool works for 12 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word32, [Bool]) - result `shouldBe` Just (0x555, []) - it "fromBool works for 20 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word32, [Bool]) - result `shouldBe` Just (0x55555, []) - it "fromBool works for 32 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - ] :: Maybe (Word32, [Bool]) - result `shouldBe` Just (0x55555555, []) - it "fromBool works for 36 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word32, [Bool]) - result `shouldBe` Just (0x55555555, [True, False, True, False]) - describe "for Word64" $ do - it "fromBool works for 0 bits" $ do - let result = fromBools [] :: Maybe (Word64, [Bool]) - result `shouldBe` Nothing - it "fromBool works for 4 bits" $ do - let result = fromBools [ True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x5, []) - it "fromBool works for 8 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x55, []) - it "fromBool works for 12 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x555, []) - it "fromBool works for 20 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x55555, []) - it "fromBool works for 32 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x55555555, []) - it "fromBool works for 36 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x555555555, []) - it "fromBool works for 64 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x5555555555555555, []) - it "fromBool works for 68 bits" $ do - let result = fromBools [ True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False, True, False, True, False - , True, False, True, False - ] :: Maybe (Word64, [Bool]) - result `shouldBe` Just (0x5555555555555555, [True, False, True, False]) diff --git a/test/HaskellWorks/Data/Conduit/ByteStringSpec.hs b/test/HaskellWorks/Data/Conduit/ByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/ByteStringSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Conduit.ByteStringSpec (spec) where + +import HaskellWorks.Data.Conduit.ByteString +import HaskellWorks.Data.Conduit.List +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Conduit.ByteStringSpec" $ do + it "Can rechunk bytestrings" $ do + runListConduit (rechunk 1) [] `shouldBe` [] + runListConduit (rechunk 1) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["0", "1", "2", "3", "4", "5"] + runListConduit (rechunk 2) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["01", "23", "45"] + runListConduit (rechunk 3) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["012", "345"] + runListConduit (rechunk 4) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["0123", "45"] + runListConduit (rechunk 5) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["01234", "5"] + runListConduit (rechunk 6) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["012345"] + runListConduit (rechunk 7) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["012345"] + runListConduit (rechunk 1) ["01", "23", "", "45", "67"] `shouldBe` ["0", "1", "2", "3", "4", "5", "6", "7"] + runListConduit (rechunk 2) ["01", "23", "", "45", "67"] `shouldBe` ["01", "23", "45", "67"] + runListConduit (rechunk 3) ["01", "23", "", "45", "67"] `shouldBe` ["012", "345", "67"] + runListConduit (rechunk 4) ["01", "23", "", "45", "67"] `shouldBe` ["0123", "4567"] + runListConduit (rechunk 5) ["01", "23", "", "45", "67"] `shouldBe` ["01234", "567"] + runListConduit (rechunk 6) ["01", "23", "", "45", "67"] `shouldBe` ["012345", "67"] + runListConduit (rechunk 7) ["01", "23", "", "45", "67"] `shouldBe` ["0123456", "7"] + runListConduit (rechunk 8) ["01", "23", "", "45", "67"] `shouldBe` ["01234567"] + runListConduit (rechunk 9) ["01", "23", "", "45", "67"] `shouldBe` ["01234567"] diff --git a/test/HaskellWorks/Data/Conduit/JsonSpec.hs b/test/HaskellWorks/Data/Conduit/JsonSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Conduit/JsonSpec.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Data.Conduit.JsonSpec (spec) where - -import Data.ByteString as BS -import Data.Conduit -import Data.Int -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Bits.Conversion -import HaskellWorks.Data.Conduit.Json -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Offset -import HaskellWorks.Data.Json.Token -import Test.Hspec - -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} - -markerToBits :: [Int64] -> [Bool] -markerToBits = runListConduit (markerToByteString =$= byteStringToBits) - -jsonToBits :: [ByteString] -> [Bool] -jsonToBits = runListConduit (textToJsonToken =$= jsonToken2Markers =$= markerToByteString =$= byteStringToBits) - -jsonToken2Markers2 :: [(ParseDelta Offset, JsonToken)] -> [Int64] -jsonToken2Markers2 = runListConduit jsonToken2Markers - -blankedJsonToInterestBits2 :: ByteString -> BitShown ByteString -blankedJsonToInterestBits2 bs = BitShown (BS.concat (runListConduit blankedJsonToInterestBits [bs])) - -spec :: Spec -spec = describe "Data.Conduit.Succinct.JsonSpec" $ do - it "No markers should produce no bits" $ - markerToBits [] `shouldBe` [] - it "One marker < 8 should produce one byte with one bit set" $ do - markerToBits [0] `shouldBe` stringToBits "10000000" - markerToBits [1] `shouldBe` stringToBits "01000000" - markerToBits [2] `shouldBe` stringToBits "00100000" - markerToBits [3] `shouldBe` stringToBits "00010000" - markerToBits [4] `shouldBe` stringToBits "00001000" - markerToBits [5] `shouldBe` stringToBits "00000100" - markerToBits [6] `shouldBe` stringToBits "00000010" - markerToBits [7] `shouldBe` stringToBits "00000001" - it "One 8 <= marker < 16 should produce one byte empty byte and another byte with one bit set" $ do - markerToBits [ 8] `shouldBe` stringToBits "00000000 10000000" - markerToBits [ 9] `shouldBe` stringToBits "00000000 01000000" - markerToBits [10] `shouldBe` stringToBits "00000000 00100000" - markerToBits [11] `shouldBe` stringToBits "00000000 00010000" - markerToBits [12] `shouldBe` stringToBits "00000000 00001000" - markerToBits [13] `shouldBe` stringToBits "00000000 00000100" - markerToBits [14] `shouldBe` stringToBits "00000000 00000010" - markerToBits [15] `shouldBe` stringToBits "00000000 00000001" - it "All markers 0 .. 7 should produce one full byte" $ - markerToBits [0, 1, 2, 3, 4, 5, 6, 7] `shouldBe` stringToBits "11111111" - it "All markers 0 .. 7 except 1 should produce one almost full byte" $ do - markerToBits [1, 2, 3, 4, 5, 6, 7] `shouldBe` stringToBits "01111111" - markerToBits [0, 2, 3, 4, 5, 6, 7] `shouldBe` stringToBits "10111111" - markerToBits [0, 1, 3, 4, 5, 6, 7] `shouldBe` stringToBits "11011111" - markerToBits [0, 1, 2, 4, 5, 6, 7] `shouldBe` stringToBits "11101111" - markerToBits [0, 1, 2, 3, 5, 6, 7] `shouldBe` stringToBits "11110111" - markerToBits [0, 1, 2, 3, 4, 6, 7] `shouldBe` stringToBits "11111011" - markerToBits [0, 1, 2, 3, 4, 5, 7] `shouldBe` stringToBits "11111101" - markerToBits [0, 1, 2, 3, 4, 5, 6] `shouldBe` stringToBits "11111110" - it "All markers 0 .. 8 should produce one almost full byte and one near empty byte" $ - markerToBits [0, 1, 2, 3, 4, 5, 6, 7, 8] `shouldBe` stringToBits "11111111 10000000" - it "Matching bits for bytes" $ - runListConduit byteStringToBits [pack [0x80], pack [0xff], pack [0x01]] `shouldBe` - stringToBits "00000001 11111111 10000000" - it "Every interesting token should produce a marker" $ - jsonToken2Markers2 [ - (ParseDelta (Offset 0) (Offset 1), JsonTokenBraceL), - (ParseDelta (Offset 1) (Offset 2), JsonTokenBraceL), - (ParseDelta (Offset 2) (Offset 3), JsonTokenBraceR), - (ParseDelta (Offset 3) (Offset 4), JsonTokenBraceR)] `shouldBe` [0, 1] - describe "When converting Json to tokens to markers to bits" $ do - it "Empty Json should produce no bits" $ - jsonToBits [""] `shouldBe` [] - it "Spaces and newlines should produce no bits" $ - jsonToBits [" \n \r \t "] `shouldBe` [] - it "number at beginning should produce one bit" $ - jsonToBits ["1234 "] `shouldBe` stringToBits "10000000" - it "false at beginning should produce one bit" $ - jsonToBits ["false "] `shouldBe` stringToBits "10000000" - it "true at beginning should produce one bit" $ - jsonToBits ["true "] `shouldBe` stringToBits "10000000" - it "string at beginning should produce one bit" $ - jsonToBits ["\"hello\" "] `shouldBe` stringToBits "10000000" - it "string at beginning should produce one bit" $ - jsonToBits ["\"\\\"\" "] `shouldBe` stringToBits "10000000" - it "left brace at beginning should produce one bit" $ - jsonToBits ["{ "] `shouldBe` stringToBits "10000000" - it "right brace at beginning should produce one bit" $ - jsonToBits ["} "] `shouldBe` stringToBits "" - it "left bracket at beginning should produce one bit" $ - jsonToBits ["[ "] `shouldBe` stringToBits "10000000" - it "right bracket at beginning should produce one bit" $ - jsonToBits ["] "] `shouldBe` stringToBits "" - it "right bracket at beginning should produce one bit" $ - jsonToBits [": "] `shouldBe` stringToBits "" - it "right bracket at beginning should produce one bit" $ - jsonToBits [", "] `shouldBe` stringToBits "" - it "Four consecutive braces should produce four bits" $ - jsonToBits ["{{}}"] `shouldBe` stringToBits "11000000" - it "Four spread out braces should produce four spread out bits" $ - jsonToBits [" { { } } "] `shouldBe` stringToBits "01010000" - describe "Can convert blanked json to Json interest bits" $ do - it "where blanked json is \" { ( ): 100, [(), t___], n___}\"" $ do - blankedJsonToInterestBits2 " { ( ): 100, [(), t___], n___}" `shouldBe` "01010000 01000011 00010000 00100000" diff --git a/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumnSpec.hs b/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumnSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumnSpec.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -module HaskellWorks.Data.Conduit.Tokenize.Attoparsec.LineColumnSpec (spec) where - -import Control.Applicative ((<|>)) -import Control.Exception (fromException) -import Control.Monad -import Control.Monad.Trans.Resource (runExceptionT) -import qualified Data.Attoparsec.ByteString.Char8 -import qualified Data.Attoparsec.Text -import Data.Conduit -import qualified Data.Conduit.List as CL -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.LineColumn -import Test.Hspec - -spec :: Spec -spec = describe "Data.Conduit.Tokenize.Attoparsec.LineColumnSpec" $ do - describe "error position" $ do - it "works for text" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badLine = 4 - badCol = 6 - parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - it "works for bytestring" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badLine = 4 - badCol = 6 - parser = Data.Attoparsec.ByteString.Char8.endOfInput <|> (Data.Attoparsec.ByteString.Char8.notChar 'b' >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - it "works in last chunk" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badLine = 6 - badCol = 5 - parser = Data.Attoparsec.Text.char 'c' <|> (Data.Attoparsec.Text.anyChar >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - it "works in last chunk" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aa\n\naaaab"] - badLine = 6 - badCol = 6 - parser = Data.Attoparsec.Text.string "bc" <|> (Data.Attoparsec.Text.anyChar >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - it "works after new line in text" $ do - let input = ["aaa\n", "aaa\n\n", "aaa", "aa\nb\naaaa"] - badLine = 5 - badCol = 1 - parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - it "works after new line in bytestring" $ do - let input = ["aaa\n", "aaa\n\n", "aaa", "aa\nb\naaaa"] - badLine = 5 - badCol = 1 - parser = Data.Attoparsec.ByteString.Char8.endOfInput <|> (Data.Attoparsec.ByteString.Char8.notChar 'b' >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - it "works for first line" $ do - let input = ["aab\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badLine = 1 - badCol = 3 - parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) - sink = sinkParser (Position 1 1) parser - sink' = sinkParserEither (Position 1 1) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Position badLine badCol - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Position badLine badCol - - describe "conduitParser" $ do - it "parses a repeated stream" $ do - let input = ["aaa\n", "aaa\naaa\n", "aaa\n"] - parser = Data.Attoparsec.Text.string "aaa" <* Data.Attoparsec.Text.endOfLine - sink = conduitParserEither (Position 1 1) parser =$= CL.consume - (Right ea) <- runExceptionT $ CL.sourceList input $$ sink - let chk a = case a of - Left{} -> False - Right (_, xs) -> xs == "aaa" - chkp l = (ParseDelta (Position l 1) (Position (l+1) 1)) - forM_ ea $ \ a -> a `shouldSatisfy` chk :: Expectation - forM_ (zip ea [1..]) $ \ (Right (pos, _), l) -> pos `shouldBe` chkp l - length ea `shouldBe` 4 - - it "positions on first line" $ do - results <- yield "hihihi\nhihi" - $$ conduitParser (Position 1 1) (Data.Attoparsec.Text.string "\n" <|> Data.Attoparsec.Text.string "hi") - =$ CL.consume - let f (a, b, c, d, e) = (ParseDelta (Position a b) (Position c d), e) - results `shouldBe` map f - [ (1, 1, 1, 3, "hi") - , (1, 3, 1, 5, "hi") - , (1, 5, 1, 7, "hi") - - , (1, 7, 2, 1, "\n") - - , (2, 1, 2, 3, "hi") - , (2, 3, 2, 5, "hi") - ] diff --git a/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/OffsetSpec.hs b/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/OffsetSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/OffsetSpec.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -module HaskellWorks.Data.Conduit.Tokenize.Attoparsec.OffsetSpec (spec) where - -import Control.Applicative ((<|>)) -import Control.Exception (fromException) -import Control.Monad -import Control.Monad.Trans.Resource (runExceptionT) -import qualified Data.Attoparsec.ByteString.Char8 -import qualified Data.Attoparsec.Text -import Data.Conduit -import qualified Data.Conduit.List as CL -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec -import HaskellWorks.Data.Conduit.Tokenize.Attoparsec.Offset -import Test.Hspec - -spec :: Spec -spec = describe "Data.Conduit.Tokenize.Attoparsec.OffsetSpec" $ do - describe "error position" $ do - it "works for text" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badOffset = 15 - parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - it "works for bytestring" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badOffset = 15 - parser = Data.Attoparsec.ByteString.Char8.endOfInput <|> (Data.Attoparsec.ByteString.Char8.notChar 'b' >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - it "works in last chunk" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badOffset = 22 - parser = Data.Attoparsec.Text.char 'c' <|> (Data.Attoparsec.Text.anyChar >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - it "works in last chunk" $ do - let input = ["aaa\na", "aaa\n\n", "aaa", "aa\n\naaaab"] - badOffset = 22 - parser = Data.Attoparsec.Text.string "bc" <|> (Data.Attoparsec.Text.anyChar >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - it "works after new line in text" $ do - let input = ["aaa\n", "aaa\n\n", "aaa", "aa\nb\naaaa"] - badOffset = 15 - parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - it "works after new line in bytestring" $ do - let input = ["aaa\n", "aaa\n\n", "aaa", "aa\nb\naaaa"] - badOffset = 15 - parser = Data.Attoparsec.ByteString.Char8.endOfInput <|> (Data.Attoparsec.ByteString.Char8.notChar 'b' >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - it "works for first line" $ do - let input = ["aab\na", "aaa\n\n", "aaa", "aab\n\naaaa"] - badOffset = 2 - parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) - sink = sinkParser (Offset 0) parser - sink' = sinkParserEither (Offset 0) parser - ea <- runExceptionT $ CL.sourceList input $$ sink - case ea of - Left e -> - case fromException e of - Just pe -> do - errorPosition pe `shouldBe` Offset badOffset - ea' <- CL.sourceList input $$ sink' - case ea' of - Left pe -> - errorPosition pe `shouldBe` Offset badOffset - - describe "conduitParser" $ do - it "parses a repeated stream" $ do - let input = ["aaa\n", "aaa\naaa\n", "aaa\n"] - parser = Data.Attoparsec.Text.string "aaa" <* Data.Attoparsec.Text.endOfLine - sink = conduitParserEither (Offset 0) parser =$= CL.consume - (Right ea) <- runExceptionT $ CL.sourceList input $$ sink - let chk a = case a of - Left{} -> False - Right (_, xs) -> xs == "aaa" - chkp l = (ParseDelta (Offset l) (Offset (l + 4))) - forM_ ea $ \ a -> a `shouldSatisfy` chk :: Expectation - forM_ (zip ea [0,4..]) $ \ (Right (pos2, _), l) -> pos2 `shouldBe` chkp l - length ea `shouldBe` 4 - - it "positions on first line" $ do - results <- yield "hihihi\nhihi" - $$ conduitParser (Offset 0) (Data.Attoparsec.Text.string "\n" <|> Data.Attoparsec.Text.string "hi") - =$ CL.consume - let f (b, d, e) = (ParseDelta (Offset b) (Offset d), e) - results `shouldBe` map f - [ (0, 2, "hi") - , (2, 4, "hi") - , (4, 6, "hi") - - , (6, 7, "\n") - - , (7, 9, "hi") - , (9, 11, "hi") - ] diff --git a/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs b/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + + +module HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec(spec) where + +import qualified Data.ByteString as BS +import Data.String +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson +import HaskellWorks.Data.Json.Succinct.Cursor.InterestBits +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +interestBitsOf :: FromBlankedJson (JsonInterestBits a) => BS.ByteString -> a +interestBitsOf = getJsonInterestBits . fromBlankedJson . fromByteString + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec" $ do + it "Evaluating interest bits" $ do + (interestBitsOf "" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "" + (interestBitsOf " \n \r \t " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "1234 " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "false " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "true " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "\"hello\" " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "\"\\\"\" " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "{ " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "} " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "[ " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "] " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf ": " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf ", " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "{{}}" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "11000000" + (interestBitsOf " { { } } " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01010000 00000000" diff --git a/test/HaskellWorks/Data/Json/SuccinctSpec.hs b/test/HaskellWorks/Data/Json/SuccinctSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Json/SuccinctSpec.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Data.Json.SuccinctSpec where - -import Data.Maybe -import HaskellWorks.Data.Bits.BitRead -import HaskellWorks.Data.Conduit.Json -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.Json.Succinct -import Test.Hspec - -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} - -spec :: Spec -spec = describe "HaskellWorks.Data.Json.SuccinctSpec" $ do - describe "When running markerToByteString" $ do - it "Marker at zero gives \"\1\"" $ - runListConduit markerToByteString [0] `shouldBe` ["\1"] - it "Marker at [0, 1, 2, 3, 4, 5, 6, 7] gives \"\\255\"" $ - runListConduit markerToByteString [0, 1, 2, 3, 4, 5, 6, 7] `shouldBe` ["\255"] - it "Marker at [0, 9, 18, 27, 36] gives \"\\255\"" $ - runListConduit markerToByteString [0, 9, 18, 27, 36] `shouldBe` ["\1", "\2", "\4", "\8", "\16"] - it "Marker at [0, 9, 27, 36] gives \"\\255\"" $ - runListConduit markerToByteString [0, 9, 27, 36] `shouldBe` ["\1", "\2", "\0", "\8", "\16"] - it "Marker at [0, 36] gives \"\\255\"" $ - runListConduit markerToByteString [0, 36] `shouldBe` ["\1", "\0", "\0", "\0", "\16"] - describe "jsonToInterestBalancedParens" $ do - it "produces the correct interest bits for {\"field\": 1}" $ - jsonToInterestBalancedParens ["{\"field\": 1}"] `shouldBe` fromJust (bitRead "110100") - describe "jsonToInterestBits" $ do - it "produces the correct interest bits for {\"field\": 1}" $ - jsonToInterestBits ["{\"field\": 1}"] `shouldBe` fromJust (bitRead "1100000000100000")