diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright John Ky (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,101 @@ +# hw-succinct +[![Circle CI](https://circleci.com/gh/haskell-works/hw-succinct.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-succinct) +Conduits for tokenizing streams. + +`hw-succinct` is a succinct JSON parsing library. It uses succinct data-structures to allow traversal of +large JSON strings with minimal memory overhead. + +It is currently considered experimental. + +For an example, see [`app/Main.hs`](../master/app/Main.hs) + +## Prerequisites +* Install `haskell-stack`. +* Install `hlint` (eg. `stack install hlint`) + +## Building + +Run the following in the shell: + + git clone git@github.com:haskell-works/hw-succinct.git + cd hw-succinct + stack setup + stack build + stack test + stack ghci --ghc-options -XOverloadedStrings \ + --main-is hw-succinct:exe:hw-succinct-example + +## Memory benchmark + +### Parsing large Json files in Scala with Argonaut + + S0U EU OU MU CCSU CMD + --------- --------- ----------- -------- -------- --------------------------------------------------------------- + 0.0 80,526.3 76,163.6 72,338.6 13,058.6 sbt console + 0.0 536,660.4 76,163.6 72,338.6 13,058.6 import java.io._, argonaut._, Argonaut._ + 0.0 552,389.1 76,163.6 72,338.6 13,058.6 val file = new File("/Users/jky/Downloads/78mbs.json" + 0.0 634,066.5 76,163.6 72,338.6 13,058.6 val array = new Array[Byte](file.length.asInstanceOf[Int]) + 0.0 644,552.3 76,163.6 72,338.6 13,058.6 val is = new FileInputStream("/Users/jky/Downloads/78mbs.json") + 0.0 655,038.1 76,163.6 72,338.6 13,058.6 is.read(array) + 294,976.0 160,159.7 1,100,365.0 79,310.8 13,748.1 val json = new String(array) + 285,182.9 146,392.6 1,956,264.5 82,679.8 14,099.6 val data = Parse.parse(json) + *********** + +### Parsing large Json files in Haskell with Aeson + + Mem (MB) CMD + -------- --------------------------------------------------------- + 302 import Data.Aeson + 302 import qualified Data.ByteString.Lazy as BSL + 302 json78m <- BSL.readFile "/Users/jky/Downloads/78mbs.json" + 1400 let !x = decode json78m :: Maybe Value + +### Parsing large Json files in Haskell with hw-succinct + + Mem (MB) CMD + -------- --------------------------------------------------------- + 274 import Foreign + 274 import qualified Data.Vector.Storable as DVS + 274 import qualified Data.ByteString as BS + 274 import System.IO.MMap + 274 import Data.Word + 274 (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/78mbs.json" ReadOnly Nothing + 601 cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + +## Examples + + import Foreign + import qualified Data.Vector.Storable as DVS + import qualified Data.ByteString as BS + import qualified Data.ByteString.Internal as BSI + import System.IO.MMap + import Data.Word + import System.CPUTime + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/78mbs.json" ReadOnly Nothing + cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + x <- measure $ jsonBsToInterestBs bs + let !y = runListConduit [bs] (unescape' "") + + import Foreign + import qualified Data.Vector.Storable as DVS + import qualified Data.ByteString as BS + import qualified Data.ByteString.Internal as BSI + import System.IO.MMap + import Data.Word + import System.CPUTime + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/part40.json" ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + x <- measure $ BS.concat $ runListConduit [bs] (blankJson =$= blankedJsonToInterestBits) + x <- measure $ jsonBsToInterestBs bs + + jsonTokenAt $ J.nextSibling $ J.firstChild $ J.nextSibling $ J.firstChild $ J.firstChild cursor + +## References +* [Original Pull Request](https://github.com/snoyberg/conduit/pull/244) +* [Typed Tagless Final Interpreters](http://okmij.org/ftp/tagless-final/course/lecture.pdf) +* [Conduit Overview](https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/conduit-overview) + + +## Special mentions +* [Sydney Paper Club](http://www.meetup.com/Sydney-Paper-Club/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = print "Hello world" diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad.Trans.Resource (MonadThrow) +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import Data.Conduit (Conduit, + (=$=)) +import qualified Data.Vector.Storable as DVS +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.Json +import HaskellWorks.Data.Conduit.Json.Blank +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Succinct.Cursor +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.BalancedParens.Simple +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic +import System.IO.MMap + +v :: DVS.Vector Word64 +v = DVS.fromList (take 1000000 (cycle [maxBound, 0])) + +setupEnv :: IO (DVS.Vector Word64) +setupEnv = return v + +setupEnvJson :: FilePath -> IO BS.ByteString +setupEnvJson filepath = do + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + return bs + +loadJson :: BS.ByteString -> JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadJson bs = fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + +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 + +jsonToInterestBitsOld :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +jsonToInterestBitsOld = textToJsonToken =$= jsonToken2Markers =$= markerToByteString + +runBlankedJsonToInterestBits :: BS.ByteString -> BS.ByteString +runBlankedJsonToInterestBits bs = BS.concat $ runListConduit blankedJsonToInterestBits [bs] + +benchRankSelect :: [Benchmark] +benchRankSelect = + [ env setupEnv $ \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]) + ] + ] + +benchRankJson40Conduits :: [Benchmark] +benchRankJson40Conduits = + [ 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) + ] + ] + +benchRankJson80Conduits :: [Benchmark] +benchRankJson80Conduits = + [ env (setupEnvJson "/Users/jky/Downloads/part80.json") $ \bs -> bgroup "Json40" + [ bench "loadJson" (whnf loadJson bs) + ] + ] + +benchRankJsonBigConduits :: [Benchmark] +benchRankJsonBigConduits = + [ env (setupEnvJson "/Users/jky/Downloads/78mb.json") $ \bs -> bgroup "JsonBig" + [ bench "loadJson" (whnf loadJson bs) + ] + ] + +main :: IO () +main = defaultMain benchRankJson40Conduits diff --git a/hw-succinct.cabal b/hw-succinct.cabal new file mode 100644 --- /dev/null +++ b/hw-succinct.cabal @@ -0,0 +1,177 @@ +name: hw-succinct +version: 0.0.0.1 +synopsis: Conduits for tokenizing streams. +description: Please see README.md +homepage: http://github.com/haskell-works/hw-succinct#readme +license: BSD3 +license-file: LICENSE +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016 John Ky +category: Data, Conduit +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 + +executable hw-succinct-example + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , attoparsec >= 0.10 + , conduit >= 1.1 && < 1.3 + , hw-succinct + , resourcet >= 1.1 + 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.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 + , HaskellWorks.Data.Json.Succinct.Cursor + , HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens + , HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson + , 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 + , HaskellWorks.Data.Succinct.BalancedParens.Simple + , HaskellWorks.Data.Succinct.NearestNeighbour + , HaskellWorks.Data.Succinct.RankSelect + , HaskellWorks.Data.Succinct.RankSelect.Binary + , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic + , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 + , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 + , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 + , HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 + , HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 + , HaskellWorks.Data.Succinct.RankSelect.Internal + , HaskellWorks.Data.Time + , HaskellWorks.Data.Vector.BoxedVectorLike + , HaskellWorks.Data.Vector.Storable.ByteString + , HaskellWorks.Data.Vector.StorableVectorLike + , HaskellWorks.Data.Vector.VectorLike + , HaskellWorks.Function + , HaskellWorks.Data.Word + build-depends: base >= 4.7 && < 5 + , array + , attoparsec >= 0.10 + , bytestring + , conduit >= 1.1 && < 1.3 + , deepseq < 1.5 + , ghc-prim + , lens + , mmap + , mono-traversable + , parsec + , QuickCheck + , random + , resourcet >= 1.1 + , safe + , text + , vector + , word8 + + default-language: Haskell2010 + ghc-options: -rtsopts -with-rtsopts=-N -Wall -O2 -Wall -msse4.2 + +test-suite hw-succinct-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: HaskellWorks.Data.Bits.BitReadSpec + , HaskellWorks.Data.Bits.BitWiseSpec + , HaskellWorks.Data.Bits.FromBoolsSpec + , 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.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.SimpleSpec + build-depends: base + , attoparsec >= 0.10 + , bytestring + , conduit >= 1.1 && < 1.3 + , hspec >= 1.3 + , hw-succinct + , mmap + , parsec + , QuickCheck + , resourcet >= 1.1 + , transformers + , vector + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-succinct + +benchmark bench + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + 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 + diff --git a/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs b/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/IsChar.hs @@ -0,0 +1,6 @@ +module HaskellWorks.Data.Attoparsec.Final.IsChar + ( module X + ) where + +import HaskellWorks.Data.Attoparsec.Final.IsChar.Char as X () +import HaskellWorks.Data.Attoparsec.Final.IsChar.Internal as X diff --git a/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Char.hs b/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Char.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Char.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/IsChar/Internal.hs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/Parser.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Attoparsec.Final.Parser + ( Parser(..) + ) where + +import HaskellWorks.Data.Attoparsec.Final.Parser.Internal diff --git a/src/HaskellWorks/Data/Attoparsec/Final/Parser/ByteString.hs b/src/HaskellWorks/Data/Attoparsec/Final/Parser/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/Parser/ByteString.hs @@ -0,0 +1,17 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/Parser/Internal.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Attoparsec/Final/Parser/Text.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits.hs @@ -0,0 +1,16 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitLength.hs @@ -0,0 +1,112 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitParse.hs @@ -0,0 +1,127 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitRead.hs @@ -0,0 +1,78 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitShow.hs @@ -0,0 +1,104 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitShown.hs @@ -0,0 +1,46 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitWise.hs @@ -0,0 +1,213 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/BitWise/String.hs @@ -0,0 +1,126 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/Conversion.hs @@ -0,0 +1,127 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/ElemFixedBitSize.hs @@ -0,0 +1,82 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/FixedBitSize.hs @@ -0,0 +1,30 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/FromBools.hs @@ -0,0 +1,51 @@ +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PopCount.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PopCount/PopCount0.hs @@ -0,0 +1,96 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PopCount/PopCount1.hs @@ -0,0 +1,11 @@ + +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PopCount/PopCount1/Broadword.hs @@ -0,0 +1,111 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Bits/PopCount/PopCount1/GHC.hs @@ -0,0 +1,95 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/ByteString.hs @@ -0,0 +1,11 @@ +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/Json.hs b/src/HaskellWorks/Data/Conduit/Json.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Json.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module HaskellWorks.Data.Conduit.Json + ( blankedJsonToInterestBits + , byteStringToBits + , markerToByteString + , blankedJsonToBalancedParens + , jsonToken2Markers + , textToJsonToken + , 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.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 + +interestingWord8s :: A.UArray Word8 Word8 +interestingWord8s = A.array (0, 255) [ + (w, if w == wOpenBracket || w == wOpenBrace || w == wOpenParen || w == wt || w == wf || w == wn || w == w1 + then 1 + else 0) + | w <- [0 .. 255]] + +blankedJsonToInterestBits :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedJsonToInterestBits = blankedJsonToInterestBits' "" + +padRight :: Word8 -> Int -> BS.ByteString -> BS.ByteString +padRight w n bs = if BS.length bs >= n then bs else fst (BS.unfoldrN n gen bs) + where gen :: ByteString -> Maybe (Word8, ByteString) + gen cs = case BS.uncons cs of + Just (c, ds) -> Just (c, ds) + Nothing -> Just (w, BS.empty) + +blankedJsonToInterestBits' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString +blankedJsonToInterestBits' rs = do + mbs <- await + case mbs of + Just bs -> do + let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs + let lencs = BS.length cs + let q = lencs + 7 `quot` 8 + let (ds, es) = BS.splitAt (q * 8) cs + let (fs, _) = BS.unfoldrN q gen ds + yield fs + blankedJsonToInterestBits' es + Nothing -> return () + where gen :: ByteString -> Maybe (Word8, ByteString) + gen as = if BS.length as == 0 + then Nothing + else Just ( BS.foldr (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (padRight 0 8 (BS.take 8 as)) + , 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 + case mbs of + Just bs -> blankedJsonToBalancedParens' bs + Nothing -> return () + +blankedJsonToBalancedParens' :: Monad m => BS.ByteString -> Conduit BS.ByteString m Bool +blankedJsonToBalancedParens' bs = case BS.uncons bs of + Just (c, cs) -> do + case c of + d | d == wOpenBrace -> yield True + d | d == wCloseBrace -> yield False + d | d == wOpenBracket -> yield True + d | d == wCloseBracket -> yield False + d | d == wOpenParen -> yield True + d | d == wCloseParen -> yield False + d | d == wt -> yield True >> yield False + d | d == wf -> yield True >> yield False + d | d == w1 -> yield True >> yield False + d | d == wn -> yield True >> yield False + _ -> return () + blankedJsonToBalancedParens' cs + Nothing -> return () + +------------------------ + +yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool +yieldBitsOfWord8 w = do + yield ((w .&. BITS.bit 0) /= 0) + yield ((w .&. BITS.bit 1) /= 0) + yield ((w .&. BITS.bit 2) /= 0) + yield ((w .&. BITS.bit 3) /= 0) + yield ((w .&. BITS.bit 4) /= 0) + yield ((w .&. BITS.bit 5) /= 0) + yield ((w .&. BITS.bit 6) /= 0) + yield ((w .&. BITS.bit 7) /= 0) + +yieldBitsofWord8s :: Monad m => [Word8] -> Conduit BS.ByteString m Bool +yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ()) + +byteStringToBits :: Monad m => Conduit BS.ByteString m Bool +byteStringToBits = do + mbs <- await + case mbs of + Just bs -> yieldBitsofWord8s (BS.unpack bs) >> byteStringToBits + Nothing -> return () diff --git a/src/HaskellWorks/Data/Conduit/Json/Blank.hs b/src/HaskellWorks/Data/Conduit/Json/Blank.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Json/Blank.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Conduit.Json.Blank + ( blankJson + ) where + +import Control.Monad +import Control.Monad.Trans.Resource (MonadThrow) +import Data.ByteString as BS +import Data.Conduit +import Data.Word +import HaskellWorks.Data.Conduit.Json.Words +import Prelude as P + +data BlankState + = Escaped + | InJson + | InString + | InNumber + | InIdent + +blankJson :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +blankJson = blankJson' InJson + +blankJson' :: MonadThrow m => BlankState -> Conduit BS.ByteString m BS.ByteString +blankJson' lastState = do + mbs <- await + case mbs of + Just bs -> do + let (!cs, Just (!nextState, _)) = unfoldrN (BS.length bs) blankByteString (lastState, bs) + yield cs + blankJson' nextState + Nothing -> return () + where + blankByteString :: (BlankState, ByteString) -> Maybe (Word8, (BlankState, ByteString)) + blankByteString (InJson, bs) = case BS.uncons bs of + Just (!c, !cs) | isLeadingDigit c -> Just (w1 , (InNumber , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wOpenParen , (InString , cs)) + Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs)) + Just (!c, !cs) -> Just (c , (InJson , cs)) + Nothing -> Nothing + blankByteString (InString, bs) = case BS.uncons bs of + Just (!c, !cs) | c == wBackslash -> Just (wSpace , (Escaped , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wCloseParen, (InJson , cs)) + Just (_ , !cs) -> Just (wSpace , (InString , cs)) + Nothing -> Nothing + blankByteString (Escaped, bs) = case BS.uncons bs of + Just (_, !cs) -> Just (wSpace, (InString, cs)) + Nothing -> Nothing + blankByteString (InNumber, bs) = case BS.uncons bs of + Just (!c, !cs) | isTrailingDigit c -> Just (w0 , (InNumber , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wOpenParen , (InString , cs)) + Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs)) + Just (!c, !cs) -> Just (c , (InJson , cs)) + Nothing -> Nothing + blankByteString (InIdent, bs) = case BS.uncons bs of + Just (!c, !cs) | isAlphabetic c -> Just (wUnderscore, (InIdent , cs)) + Just (!c, !cs) | isLeadingDigit c -> Just (w1 , (InNumber , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wOpenParen , (InString , cs)) + Just (!c, !cs) -> Just (c , (InJson , cs)) + Nothing -> Nothing diff --git a/src/HaskellWorks/Data/Conduit/Json/Words.hs b/src/HaskellWorks/Data/Conduit/Json/Words.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Json/Words.hs @@ -0,0 +1,88 @@ +module HaskellWorks.Data.Conduit.Json.Words where + +import Data.Char +import Data.Word + +wBackslash :: Word8 +wBackslash = fromIntegral (ord '\\') + +wDoubleQuote :: Word8 +wDoubleQuote = fromIntegral (ord '"') + +wUnderscore :: Word8 +wUnderscore = fromIntegral (ord '_') + +wSpace :: Word8 +wSpace = fromIntegral (ord ' ') + +wOpenParen :: Word8 +wOpenParen = fromIntegral (ord '(') + +wCloseParen :: Word8 +wCloseParen = fromIntegral (ord ')') + +wOpenBracket :: Word8 +wOpenBracket = fromIntegral (ord '[') + +wCloseBracket :: Word8 +wCloseBracket = fromIntegral (ord ']') + +wOpenBrace :: Word8 +wOpenBrace = fromIntegral (ord '{') + +wCloseBrace :: Word8 +wCloseBrace = fromIntegral (ord '}') + +wPlus :: Word8 +wPlus = fromIntegral (ord '+') + +wA :: Word8 +wA = fromIntegral (ord 'A') + +wa :: Word8 +wa = fromIntegral (ord 'a') + +we :: Word8 +we = fromIntegral (ord 'e') + +wE :: Word8 +wE = fromIntegral (ord 'E') + +wf :: Word8 +wf = fromIntegral (ord 'f') + +wn :: Word8 +wn = fromIntegral (ord 'n') + +wt :: Word8 +wt = fromIntegral (ord 't') + +wz :: Word8 +wz = fromIntegral (ord 'z') + +wZ :: Word8 +wZ = fromIntegral (ord 'Z') + +wDot :: Word8 +wDot = fromIntegral (ord '.') + +wMinus :: Word8 +wMinus = fromIntegral (ord '-') + +w0 :: Word8 +w0 = fromIntegral (ord '0') + +w1 :: Word8 +w1 = fromIntegral (ord '1') + +w9 :: Word8 +w9 = fromIntegral (ord '9') + +isLeadingDigit :: Word8 -> Bool +isLeadingDigit w = w == wMinus || (w >= w0 && w <= w9) + +isTrailingDigit :: Word8 -> Bool +isTrailingDigit w = w == wPlus || w == wMinus || (w >= w0 && w <= w9) || w == wDot || w == wE || w == we + +isAlphabetic :: Word8 -> Bool +isAlphabetic w = (w >= wA && w <= wZ) || (w >= wa && w <= wz) diff --git a/src/HaskellWorks/Data/Conduit/List.hs b/src/HaskellWorks/Data/Conduit/List.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/List.hs @@ -0,0 +1,11 @@ + +module HaskellWorks.Data.Conduit.List + ( runListConduit + ) where + +import Data.Conduit +import Data.Conduit.List as CL +import Prelude as P + +runListConduit :: Conduit i [] o -> [i] -> [o] +runListConduit c is = P.concat $ sourceList is =$ c $$ consume diff --git a/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec.hs b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec.hs @@ -0,0 +1,29 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Internal.hs @@ -0,0 +1,196 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumn.hs @@ -0,0 +1,84 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/Offset.hs @@ -0,0 +1,79 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/FromByteString.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/FromForeignRegion.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Final/Tokenize.hs @@ -0,0 +1,6 @@ +module HaskellWorks.Data.Json.Final.Tokenize + ( parseJsonToken + ) where + +import HaskellWorks.Data.Attoparsec.Final.Parser.ByteString () +import HaskellWorks.Data.Json.Final.Tokenize.Internal diff --git a/src/HaskellWorks/Data/Json/Final/Tokenize/Internal.hs b/src/HaskellWorks/Data/Json/Final/Tokenize/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Final/Tokenize/Internal.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Json.Final.Tokenize.Internal + ( IsChar(..) + , JsonToken(..) + , AFP.Parser(..) + , parseJsonToken + , parseJsonTokenString + , escapedChar + ) where + +import Control.Applicative +import Control.Monad +import qualified Data.Attoparsec.ByteString.Char8 as BC +import qualified Data.Attoparsec.Combinator as AC +import qualified Data.Attoparsec.Types as T +import Data.Bits +import Data.Char +import Data.String +import HaskellWorks.Data.Attoparsec.Final.IsChar +import HaskellWorks.Data.Attoparsec.Final.Parser as AFP +import HaskellWorks.Data.Json.Token + +hexDigitNumeric :: AFP.Parser t => T.Parser t Int +hexDigitNumeric = do + c <- satisfyChar (\c -> '0' <= c && c <= '9') + return $ ord c - ord '0' + +hexDigitAlphaLower :: AFP.Parser t => T.Parser t Int +hexDigitAlphaLower = do + c <- satisfyChar (\c -> 'a' <= c && c <= 'z') + return $ ord c - ord 'a' + 10 + +hexDigitAlphaUpper :: AFP.Parser t => T.Parser t Int +hexDigitAlphaUpper = do + c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') + return $ ord c - ord 'A' + 10 + +hexDigit :: AFP.Parser t => T.Parser t Int +hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper + +verbatimChar :: AFP.Parser t => T.Parser t Char +verbatimChar = satisfyChar (BC.notInClass "\"\\") "invalid string character" + +escapedChar :: (IsString t, AFP.Parser t) => T.Parser t Char +escapedChar = do + _ <- string "\\" + ( char '"' >> return '"' ) <|> + ( char 'b' >> return '\b' ) <|> + ( char 'n' >> return '\n' ) <|> + ( char 'f' >> return '\f' ) <|> + ( char 'r' >> return '\r' ) <|> + ( char 't' >> return '\t' ) <|> + ( char '\\' >> return '\\' ) <|> + ( char '\'' >> return '\'' ) <|> + ( char '/' >> return '/' ) + +escapedCode :: (IsString t, AFP.Parser t) => T.Parser t Char +escapedCode = do + _ <- string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + +parseJsonTokenString :: (JsonTokenLike j, AFP.Parser t, Alternative (T.Parser t), IsString t) => T.Parser t j +parseJsonTokenString = do + _ <- string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- string "\"" + return $ jsonTokenString value + +parseJsonTokenBraceL :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenBraceL = string "{" >> return jsonTokenBraceL + +parseJsonTokenBraceR :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenBraceR = string "}" >> return jsonTokenBraceR + +parseJsonTokenBracketL :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenBracketL = string "[" >> return jsonTokenBracketL + +parseJsonTokenBracketR :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenBracketR = string "]" >> return jsonTokenBracketR + +parseJsonTokenComma :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenComma = string "," >> return jsonTokenComma + +parseJsonTokenColon :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenColon = string ":" >> return jsonTokenColon + +parseJsonTokenWhitespace :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenWhitespace = do + _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] + return jsonTokenWhitespace + +parseJsonTokenNull :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenNull = string "null" >> return jsonTokenNull + +parseJsonTokenBoolean :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenBoolean = true <|> false + where + true = string "true" >> return (jsonTokenBoolean True) + false = string "false" >> return (jsonTokenBoolean False) + +parseJsonTokenDouble :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonTokenDouble = liftM jsonTokenNumber rational + +parseJsonToken :: (JsonTokenLike j, AFP.Parser t, IsString t) => T.Parser t j +parseJsonToken = + parseJsonTokenString <|> + parseJsonTokenBraceL <|> + parseJsonTokenBraceR <|> + parseJsonTokenBracketL <|> + parseJsonTokenBracketR <|> + parseJsonTokenComma <|> + parseJsonTokenColon <|> + parseJsonTokenWhitespace <|> + parseJsonTokenNull <|> + parseJsonTokenBoolean <|> + parseJsonTokenDouble diff --git a/src/HaskellWorks/Data/Json/Succinct.hs b/src/HaskellWorks/Data/Json/Succinct.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct.hs @@ -0,0 +1,6 @@ +module HaskellWorks.Data.Json.Succinct + ( module X + ) where + +import HaskellWorks.Data.Json.Succinct.Cursor as X +import HaskellWorks.Data.Json.Succinct.Transform as X diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor + ( module X + , jsonTokenAt + , firstChild + , nextSibling + , parent + , depth + , subtreeSize + ) where + +import qualified Data.Attoparsec.ByteString.Char8 as ABC +import Data.ByteString.Internal as BSI +import HaskellWorks.Data.Json.Final.Tokenize.Internal +import HaskellWorks.Data.Json.Succinct.Cursor.CursorType as X +import HaskellWorks.Data.Json.Succinct.Cursor.Internal as X +import HaskellWorks.Data.Positioning +import qualified HaskellWorks.Data.Succinct.BalancedParens as BP +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Vector.VectorLike + +jsonTokenAt :: (Rank1 w, Select1 v) => JsonCursor ByteString v w -> JsonToken +jsonTokenAt k = case ABC.parse parseJsonToken (vDrop (toCount (jsonCursorPos k)) (cursorText k)) of + ABC.Fail {} -> error "Failed to parse token in cursor" + ABC.Partial _ -> error "Failed to parse token in cursor" + ABC.Done _ r -> r + +firstChild :: JsonCursor t v u -> JsonCursor t v u +firstChild k = k { cursorRank = BP.firstChild (balancedParens k) (cursorRank k) } + +nextSibling :: BP.BalancedParens u => JsonCursor t v u -> JsonCursor t v u +nextSibling k = k { cursorRank = BP.nextSibling (balancedParens k) (cursorRank k) } + +parent :: BP.BalancedParens u => JsonCursor t v u -> JsonCursor t v u +parent k = k { cursorRank = BP.parent (balancedParens k) (cursorRank k) } + +depth :: (BP.BalancedParens u, Rank1 u, Rank0 u) => JsonCursor t v u -> Count +depth k = BP.depth (balancedParens k) (cursorRank k) + +subtreeSize :: BP.BalancedParens u => JsonCursor t v u -> Count +subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k) + diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens + ( JsonBalancedParens(..) + , getJsonBalancedParens + ) where + +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 +import HaskellWorks.Data.Succinct.BalancedParens as BP + +newtype JsonBalancedParens a = JsonBalancedParens a + +getJsonBalancedParens :: JsonBalancedParens a -> a +getJsonBalancedParens (JsonBalancedParens a) = a + +instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where + fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + +instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where + fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + +instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where + fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) + +instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where + fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (DVS.unfoldr fromBools (runListConduit blankedJsonToBalancedParens bj))) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs @@ -0,0 +1,23 @@ + +module HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson + ( BlankedJson(..) + , FromBlankedJson(..) + , getBlankedJson + ) where + +import qualified Data.ByteString as BS +import HaskellWorks.Data.ByteString +import HaskellWorks.Data.Conduit.Json.Blank +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString + +newtype BlankedJson = BlankedJson [BS.ByteString] deriving (Eq, Show) + +getBlankedJson :: BlankedJson -> [BS.ByteString] +getBlankedJson (BlankedJson bs) = bs + +class FromBlankedJson a where + fromBlankedJson :: BlankedJson -> a + +instance FromByteString BlankedJson where + fromByteString bs = BlankedJson (runListConduit blankJson (chunkedBy 4096 bs)) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/CursorType.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/CursorType.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/CursorType.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.CursorType + ( HasJsonCursorType(..) + , JsonCursorType(..) + , jsonCursorPos + ) where + +import qualified Data.ByteString as BS +import Data.Char +import HaskellWorks.Data.Json.Succinct.Cursor.Internal +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Vector.VectorLike + +data JsonCursorType + = JsonCursorArray + | JsonCursorBool + | JsonCursorNull + | JsonCursorNumber + | JsonCursorObject + | JsonCursorString + deriving (Eq, Show) + +class HasJsonCursorType k where + jsonCursorType :: k -> JsonCursorType + +jsonCursorType' :: Char -> JsonCursorType +jsonCursorType' c = case c of + '[' -> JsonCursorArray + 't' -> JsonCursorBool + 'f' -> JsonCursorBool + '0' -> JsonCursorNumber + '1' -> JsonCursorNumber + '2' -> JsonCursorNumber + '3' -> JsonCursorNumber + '4' -> JsonCursorNumber + '5' -> JsonCursorNumber + '6' -> JsonCursorNumber + '7' -> JsonCursorNumber + '8' -> JsonCursorNumber + '9' -> JsonCursorNumber + '+' -> JsonCursorNumber + '-' -> JsonCursorNumber + 'n' -> JsonCursorNull + '{' -> JsonCursorObject + '"' -> JsonCursorString + _ -> error "Invalid JsonCursor cursorRank" + +jsonCursorPos :: (Rank1 w, Select1 v, VectorLike s) => JsonCursor s v w -> Position +jsonCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1) + where ik = interests k + bpk = balancedParens k + +jsonCursorElemAt :: (Rank1 w, Select1 v, VectorLike s) => JsonCursor s v w -> Elem s +jsonCursorElemAt k = cursorText k !!! jsonCursorPos k + +instance (Rank1 i, Select1 i, Rank1 b) => HasJsonCursorType (JsonCursor String i b) where + jsonCursorType = jsonCursorType' . jsonCursorElemAt + +instance (Rank1 i, Select1 i, Rank1 b) => HasJsonCursorType (JsonCursor BS.ByteString i b) where + jsonCursorType = jsonCursorType' . chr . fromIntegral . jsonCursorElemAt diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.InterestBits + ( JsonInterestBits(..) + , getJsonInterestBits + ) where + +import Control.Applicative +import qualified Data.ByteString as BS +import Data.ByteString.Internal +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Conduit.Json +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson +import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 + +newtype JsonInterestBits a = JsonInterestBits a + +getJsonInterestBits :: JsonInterestBits a -> a +getJsonInterestBits (JsonInterestBits a) = a + +blankedJsonBssToInterestBitsBs :: [ByteString] -> ByteString +blankedJsonBssToInterestBitsBs bss = BS.concat $ runListConduit blankedJsonToInterestBits bss + +genInterest :: ByteString -> Maybe (Word8, ByteString) +genInterest = BS.uncons + +genInterestForever :: ByteString -> Maybe (Word8, ByteString) +genInterestForever bs = BS.uncons bs <|> Just (0, bs) + +instance FromBlankedJson (JsonInterestBits (BitShown BS.ByteString)) where + fromBlankedJson (BlankedJson bj) = JsonInterestBits (BitShown (BS.unfoldr genInterest (blankedJsonBssToInterestBitsBs bj))) + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word8))) where + fromBlankedJson (BlankedJson bj) = JsonInterestBits (BitShown (DVS.unfoldr genInterest (blankedJsonBssToInterestBitsBs bj))) + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word16))) where + fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) + newLen = (BS.length interestBS + 1) `div` 2 * 2 + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word32))) where + fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) + newLen = (BS.length interestBS + 3) `div` 4 * 4 + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word64))) where + fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +instance FromBlankedJson (JsonInterestBits Poppy512) where + fromBlankedJson = JsonInterestBits . makePoppy512 . bitShown . getJsonInterestBits . fromBlankedJson diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.Internal + ( JsonCursor(..) + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal as BSI +import Data.String +import qualified Data.Vector.Storable as DVS +import Data.Word +import Foreign.ForeignPtr +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.FromForeignRegion +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 + +data JsonCursor t v w = JsonCursor + { cursorText :: !t + , interests :: !v + , balancedParens :: !w + , cursorRank :: !Count + } + deriving (Eq, Show) + +instance (FromBlankedJson (JsonInterestBits a), FromBlankedJson (JsonBalancedParens b)) + => FromByteString (JsonCursor BS.ByteString a b) where + fromByteString bs = JsonCursor + { cursorText = bs + , interests = getJsonInterestBits (fromBlankedJson blankedJson) + , balancedParens = getJsonBalancedParens (fromBlankedJson blankedJson) + , cursorRank = 1 + } + where blankedJson :: BlankedJson + blankedJson = fromByteString bs + +instance IsString (JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])) where + fromString :: String -> JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + fromString s = JsonCursor + { cursorText = s + , cursorRank = 1 + , balancedParens = SimpleBalancedParens (jsonToInterestBalancedParens [bs]) + , interests = BitShown interests' + } + where bs = BSC.pack s :: BS.ByteString + interests' = jsonToInterestBits [bs] + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) where + fromString = fromByteString . BSC.pack + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + diff --git a/src/HaskellWorks/Data/Json/Succinct/Transform.hs b/src/HaskellWorks/Data/Json/Succinct/Transform.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Transform.hs @@ -0,0 +1,18 @@ +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/Json/Token.hs b/src/HaskellWorks/Data/Json/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Token.hs @@ -0,0 +1,41 @@ +module HaskellWorks.Data.Json.Token (JsonToken(..), JsonTokenLike(..)) where + +class JsonTokenLike j where + jsonTokenBraceL :: j + jsonTokenBraceR :: j + jsonTokenBracketL :: j + jsonTokenBracketR :: j + jsonTokenComma :: j + jsonTokenColon :: j + jsonTokenWhitespace :: j + jsonTokenString :: String -> j + jsonTokenBoolean :: Bool -> j + jsonTokenNumber :: Double -> j + jsonTokenNull :: j + +data JsonToken + = JsonTokenBraceL + | JsonTokenBraceR + | JsonTokenBracketL + | JsonTokenBracketR + | JsonTokenComma + | JsonTokenColon + | JsonTokenWhitespace + | JsonTokenString String + | JsonTokenBoolean Bool + | JsonTokenNumber Double + | JsonTokenNull + deriving (Eq, Show) + +instance JsonTokenLike JsonToken where + jsonTokenBraceL = JsonTokenBraceL + jsonTokenBraceR = JsonTokenBraceR + jsonTokenBracketL = JsonTokenBracketL + jsonTokenBracketR = JsonTokenBracketR + jsonTokenComma = JsonTokenComma + jsonTokenColon = JsonTokenColon + jsonTokenWhitespace = JsonTokenWhitespace + jsonTokenString = JsonTokenString + jsonTokenBoolean = JsonTokenBoolean + jsonTokenNumber = JsonTokenNumber + jsonTokenNull = JsonTokenNull diff --git a/src/HaskellWorks/Data/Positioning.hs b/src/HaskellWorks/Data/Positioning.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Positioning.hs @@ -0,0 +1,34 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Search.hs @@ -0,0 +1,12 @@ +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.hs b/src/HaskellWorks/Data/Succinct.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct.hs @@ -0,0 +1,12 @@ +-- | +-- Copyright: 2016 John Ky +-- License: MIT +-- +-- Succinct operations. +module HaskellWorks.Data.Succinct + ( module X + ) where + +import HaskellWorks.Data.Succinct.BalancedParens as X +import HaskellWorks.Data.Succinct.NearestNeighbour as X +import HaskellWorks.Data.Succinct.RankSelect as X diff --git a/src/HaskellWorks/Data/Succinct/BalancedParens.hs b/src/HaskellWorks/Data/Succinct/BalancedParens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/BalancedParens.hs @@ -0,0 +1,6 @@ +module HaskellWorks.Data.Succinct.BalancedParens + ( module X + ) where + +import HaskellWorks.Data.Succinct.BalancedParens.Internal as X +import HaskellWorks.Data.Succinct.BalancedParens.Simple as X diff --git a/src/HaskellWorks/Data/Succinct/BalancedParens/Internal.hs b/src/HaskellWorks/Data/Succinct/BalancedParens/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/BalancedParens/Internal.hs @@ -0,0 +1,32 @@ +module HaskellWorks.Data.Succinct.BalancedParens.Internal + ( BalancedParens(..) + , firstChild + , nextSibling + , parent + , depth + , subtreeSize + ) where + +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 + +class BalancedParens v where + findOpen :: v -> Count -> Count + findClose :: v -> Count -> Count + enclose :: v -> Count -> Count + +firstChild :: v -> Count -> Count +firstChild _ = (+ 1) + +nextSibling :: BalancedParens v => v -> Count -> Count +nextSibling v p = findClose v p + 1 + +parent :: BalancedParens v => v -> Count -> Count +parent = enclose + +depth :: (BalancedParens v, Rank0 v, Rank1 v) => v -> Count -> Count +depth v p = let q = findOpen v p in rank1 v q - rank0 v q + +subtreeSize :: BalancedParens v => v -> Count -> Count +subtreeSize v p = (findClose v p - p + 1) `quot` 2 diff --git a/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs b/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/BalancedParens/Simple.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module HaskellWorks.Data.Succinct.BalancedParens.Simple + ( SimpleBalancedParens(..) + , closeAt + , findOpen + , findClose + , findClose' + , openAt + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.BalancedParens.Internal +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import Prelude as P + +newtype SimpleBalancedParens a = SimpleBalancedParens a + deriving (BitLength, Eq, BitShow, TestBit, Rank0, Rank1, Select0, Select1) + +instance Functor SimpleBalancedParens where + fmap f (SimpleBalancedParens a) = SimpleBalancedParens (f a) + +instance BitShow a => Show (SimpleBalancedParens a) where + show = bitShow + +closeAt :: TestBit a => a -> Count -> Bool +closeAt v c = not (v .?. lastPositionOf c) + +openAt :: TestBit a => a -> Count -> Bool +openAt v c = v .?. lastPositionOf c + +require :: Bool -> String -> a -> a +require p msg v = if p then v else error msg + +findOpen' :: (BitLength a, TestBit a) => Count -> SimpleBalancedParens a -> Count -> Count +findOpen' c v p = + require (0 < p && p <= bitLength v) "Out of bounds" $ + if v `openAt` p + then if c == 0 + then p + else findOpen' (c - 1) v (p - 1) + else findOpen' (c + 1) v (p - 1) + +findClose' :: (BitLength a, TestBit a) => Count -> SimpleBalancedParens a -> Count -> Count +findClose' c v p = + require (1 < p && p <= bitLength v) "Out of bounds" $ + if v `closeAt` p + then if c == 0 + then p + else findClose' (c + 1) v (p + 1) + else findClose' (c - 1) v (p + 1) + +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) + +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) + +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) + +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) + +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) + +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) + +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) + +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) + +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) diff --git a/src/HaskellWorks/Data/Succinct/NearestNeighbour.hs b/src/HaskellWorks/Data/Succinct/NearestNeighbour.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/NearestNeighbour.hs @@ -0,0 +1,14 @@ +module HaskellWorks.Data.Succinct.NearestNeighbour + ( bitPred + , bitSucc + ) where + +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 + +bitPred :: (Rank1 v, Select1 v) => v -> Count -> Count +bitPred v p = select1 v (rank1 v p - 1) + +bitSucc :: (Rank1 v, Select1 v) => v -> Count -> Count +bitSucc v p = select1 v (rank1 v p + 1) diff --git a/src/HaskellWorks/Data/Succinct/RankSelect.hs b/src/HaskellWorks/Data/Succinct/RankSelect.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Succinct.RankSelect + ( module X + ) where + +import HaskellWorks.Data.Succinct.RankSelect.Internal as X diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Succinct.RankSelect.Binary + ( module X + ) where + +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic as X diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic.hs @@ -0,0 +1,9 @@ + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic + ( module X + ) where + +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 as X +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 as X +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 as X +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 as X diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank0.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank0.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank0.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 + ( Rank0(..) + ) where + +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.ElemFixedBitSize +import HaskellWorks.Data.Bits.PopCount.PopCount0 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 as X +import HaskellWorks.Data.Vector.VectorLike +import Prelude as P + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +class Rank0 v where + rank0 :: v -> Count -> Count + +deriving instance Rank0 a => Rank0 (BitShown a) + +instance Rank0 Word8 where + rank0 v s0 = s0 - rank1 v s0 + {-# INLINABLE rank0 #-} + +instance Rank0 Word16 where + rank0 v s0 = s0 - rank1 v s0 + {-# INLINABLE rank0 #-} + +instance Rank0 Word32 where + rank0 v s0 = s0 - rank1 v s0 + {-# INLINABLE rank0 #-} + +instance Rank0 Word64 where + rank0 v s0 = s0 - rank1 v s0 + {-# INLINABLE rank0 #-} + +instance Rank0 [Bool] where + rank0 = go 0 + where go r _ 0 = r + go r (False:bs) p = go (r + 1) bs (p - 1) + go r (True:bs) p = go r bs (p - 1) + go _ [] _ = error "Out of range" + {-# INLINABLE rank0 #-} + +instance Rank0 [Word8] where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 [Word16] where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 [Word32] where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 [Word64] where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DV.Vector Word8) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DV.Vector Word16) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DV.Vector Word32) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DV.Vector Word64) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DVS.Vector Word8) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DVS.Vector Word16) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DVS.Vector Word32) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} + +instance Rank0 (DVS.Vector Word64) where + rank0 v p = popCount0 prefix + if r == 0 then 0 else (`rank0` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank0 #-} diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank1.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank1.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank1.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 + ( Rank1(..) + ) where + +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.ElemFixedBitSize +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Vector.VectorLike +import Prelude as P + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +class Rank1 v where + rank1 :: v -> Count -> Count + +deriving instance Rank1 a => Rank1 (BitShown a) + +instance Rank1 Word8 where + rank1 _ 0 = 0 + rank1 v s0 = + -- Shift out bits after given position. + let r0 = v .<. (8 - s0) in + -- Count set bits in parallel. + let r1 = (r0 .&. 0x55) + ((r0 .>. 1) .&. 0x55) in + let r2 = (r1 .&. 0x33) + ((r1 .>. 2) .&. 0x33) in + let r3 = (r2 .&. 0x0f) + ((r2 .>. 4) .&. 0x0f) in + let r4 = r3 `mod` 255 in + Count $ fromIntegral r4 + {-# INLINABLE rank1 #-} + +instance Rank1 Word16 where + rank1 _ 0 = 0 + rank1 v s0 = + -- Shift out bits after given position. + let r0 = v .<. (16 - s0) in + -- Count set bits in parallel. + let r1 = (r0 .&. 0x5555) + ((r0 .>. 1) .&. 0x5555) in + let r2 = (r1 .&. 0x3333) + ((r1 .>. 2) .&. 0x3333) in + let r3 = (r2 .&. 0x0f0f) + ((r2 .>. 4) .&. 0x0f0f) in + let r4 = r3 `mod` 255 in + Count $ fromIntegral r4 + {-# INLINABLE rank1 #-} + +instance Rank1 Word32 where + rank1 _ 0 = 0 + rank1 v s0 = + -- Shift out bits after given position. + let r0 = v .<. (32 - s0) in + -- Count set bits in parallel. + let r1 = (r0 .&. 0x55555555) + ((r0 .>. 1) .&. 0x55555555) in + let r2 = (r1 .&. 0x33333333) + ((r1 .>. 2) .&. 0x33333333) in + let r3 = (r2 .&. 0x0f0f0f0f) + ((r2 .>. 4) .&. 0x0f0f0f0f) in + let r4 = r3 `mod` 255 in + Count $ fromIntegral r4 + {-# INLINABLE rank1 #-} + +instance Rank1 Word64 where + rank1 _ 0 = 0 + rank1 v s0 = + -- Shift out bits after given position. + let r0 = v .<. (64 - s0) in + -- Count set bits in parallel. + let r1 = (r0 .&. 0x5555555555555555) + ((r0 .>. 1) .&. 0x5555555555555555) in + let r2 = (r1 .&. 0x3333333333333333) + ((r1 .>. 2) .&. 0x3333333333333333) in + let r3 = (r2 .&. 0x0f0f0f0f0f0f0f0f) + ((r2 .>. 4) .&. 0x0f0f0f0f0f0f0f0f) in + let r4 = r3 `mod` 255 in + Count $ fromIntegral r4 + {-# INLINABLE rank1 #-} + +instance Rank1 [Bool] where + rank1 = go 0 + where go r _ 0 = r + go r (True :bs) p = go (r + 1) bs (p - 1) + go r (False:bs) p = go r bs (p - 1) + go _ [] _ = error "Out of range" + {-# INLINABLE rank1 #-} + +instance Rank1 [Word8] where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 [Word16] where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 [Word32] where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 [Word64] where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = take (fromIntegral q) v + maybeElem = v !! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DV.Vector Word8) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DV.Vector Word16) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DV.Vector Word32) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DV.Vector Word64) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DV.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DVS.Vector Word8) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DVS.Vector Word16) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DVS.Vector Word32) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} + +instance Rank1 (DVS.Vector Word64) where + rank1 v p = popCount1 prefix + if r == 0 then 0 else (`rank1` r) maybeElem + where (q, r) = if p < 1 then (0, 0) else ((p - 1) `quot` elemFixedBitSize v, ((p - 1) `rem` elemFixedBitSize v) + 1) + prefix = DVS.take (fromIntegral q) v + maybeElem = v !!! fromIntegral q + {-# INLINABLE rank1 #-} diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select0.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select0.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select0.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 + ( Select0(..) + ) where + +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.ElemFixedBitSize +import HaskellWorks.Data.Bits.PopCount.PopCount0 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Vector.VectorLike + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +class Select0 v where + select0 :: v -> Count -> Count + +deriving instance Select0 a => Select0 (BitShown a) + +-- TODO: Implement NOT in terms of select for word-16 +instance Select0 Word8 where + select0 v = select1 (comp v) + {-# INLINABLE select0 #-} + +instance Select0 Word16 where + select0 v = select1 (comp v) + {-# INLINABLE select0 #-} + +instance Select0 Word32 where + select0 v = select1 (comp v) + {-# INLINABLE select0 #-} + +instance Select0 Word64 where + select0 v = select1 (comp v) + {-# INLINABLE select0 #-} + +instance Select0 [Bool] where + select0 = go 0 + where go r _ 0 = r + go r (False:bs) c = go (r + 1) bs (c - 1) + go r (True:bs) c = go (r + 1) bs c + go _ [] _ = error "Out of range" + {-# INLINABLE select0 #-} + +instance Select0 [Word8] where + select0 v c = go v c 0 + where go :: [Word8] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select0 #-} + +instance Select0 [Word16] where + select0 v c = go v c 0 + where go :: [Word16] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select0 #-} + +instance Select0 [Word32] where + select0 v c = go v c 0 + where go :: [Word32] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select0 #-} + +instance Select0 [Word64] where + select0 v c = go v c 0 + where go :: [Word64] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select0 #-} + +instance Select0 (DV.Vector Word8) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DV.Vector Word16) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DV.Vector Word32) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DV.Vector Word64) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DVS.Vector Word8) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DVS.Vector Word16) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DVS.Vector Word32) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} + +instance Select0 (DVS.Vector Word64) where + select0 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount0 w of + pc | d <= pc -> select0 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select0 #-} diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select1.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select1.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select1.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 + ( Select1(..) + ) where + +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.ElemFixedBitSize +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Vector.VectorLike +import Prelude as P + +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +class Select1 v where + select1 :: v -> Count -> Count + +deriving instance Select1 a => Select1 (BitShown a) + +-- TODO: Implement NOT interms of select for word-16 +instance Select1 Word8 where + select1 _ 0 = 0 + select1 v p = select1 (fromIntegral v :: Word16) p + {-# INLINABLE select1 #-} + +-- TODO: Remove redundant code to optimise +instance Select1 Word16 where + select1 _ 0 = 0 + select1 v rn = + -- Do a normal parallel bit count for a 64-bit integer, + -- but store all intermediate steps. + let a = (v .&. 0x5555) + ((v .>. 1) .&. 0x5555) in + let b = (a .&. 0x3333) + ((a .>. 2) .&. 0x3333) in + let c = (b .&. 0x0f0f) + ((b .>. 4) .&. 0x0f0f) in + let d = (c .&. 0x00ff) + ((c .>. 8) .&. 0x00ff) in + -- Now do branchless select! + let r0 = d + 1 - (fromIntegral (getCount rn) :: Word16) in + let s0 = 64 :: Word16 in + let t0 = (d .>. 32) + (d .>. 48) in + let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in + let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in + let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in + let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in + let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in + let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in + let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in + let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in + let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in + let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in + let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in + let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in + let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in + let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in + let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in + let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in + fromIntegral s6 + {-# INLINABLE select1 #-} + +-- TODO: Remove redundant code to optimise +instance Select1 Word32 where + select1 _ 0 = 0 + select1 v rn = + -- Do a normal parallel bit count for a 64-bit integer, + -- but store all intermediate steps. + let a = (v .&. 0x55555555) + ((v .>. 1) .&. 0x55555555) in + let b = (a .&. 0x33333333) + ((a .>. 2) .&. 0x33333333) in + let c = (b .&. 0x0f0f0f0f) + ((b .>. 4) .&. 0x0f0f0f0f) in + let d = (c .&. 0x00ff00ff) + ((c .>. 8) .&. 0x00ff00ff) in + let e = (d .&. 0x000000ff) + ((d .>. 16) .&. 0x000000ff) in + -- Now do branchless select! + let r0 = e + 1 - (fromIntegral (getCount rn) :: Word32) in + let s0 = 64 :: Word32 in + let t0 = (d .>. 32) + (d .>. 48) in + let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in + let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in + let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in + let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in + let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in + let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in + let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in + let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in + let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in + let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in + let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in + let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in + let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in + let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in + let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in + let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in + fromIntegral s6 + {-# INLINABLE select1 #-} + +instance Select1 Word64 where + select1 _ 0 = 0 + select1 v rn = + -- Do a normal parallel bit count for a 64-bit integer, + -- but store all intermediate steps. + let a = (v .&. 0x5555555555555555) + ((v .>. 1) .&. 0x5555555555555555) in + let b = (a .&. 0x3333333333333333) + ((a .>. 2) .&. 0x3333333333333333) in + let c = (b .&. 0x0f0f0f0f0f0f0f0f) + ((b .>. 4) .&. 0x0f0f0f0f0f0f0f0f) in + let d = (c .&. 0x00ff00ff00ff00ff) + ((c .>. 8) .&. 0x00ff00ff00ff00ff) in + let e = (d .&. 0x0000ffff0000ffff) + ((d .>. 16) .&. 0x0000ffff0000ffff) in + let f = (e .&. 0x00000000ffffffff) + ((e .>. 32) .&. 0x00000000ffffffff) in + -- Now do branchless select! + let r0 = f + 1 - fromIntegral (getCount rn) :: Word64 in + let s0 = 64 :: Word64 in + let t0 = (d .>. 32) + (d .>. 48) in + let s1 = s0 - ((t0 - r0) .&. 256) .>. 3 in + let r1 = r0 - (t0 .&. ((t0 - r0) .>. 8)) in + let t1 = (d .>. fromIntegral (s1 - 16)) .&. 0xff in + let s2 = s1 - ((t1 - r1) .&. 256) .>. 4 in + let r2 = r1 - (t1 .&. ((t1 - r1) .>. 8)) in + let t2 = (c .>. fromIntegral (s2 - 8)) .&. 0xf in + let s3 = s2 - ((t2 - r2) .&. 256) .>. 5 in + let r3 = r2 - (t2 .&. ((t2 - r2) .>. 8)) in + let t3 = (b .>. fromIntegral (s3 - 4)) .&. 0x7 in + let s4 = s3 - ((t3 - r3) .&. 256) .>. 6 in + let r4 = r3 - (t3 .&. ((t3 - r3) .>. 8)) in + let t4 = (a .>. fromIntegral (s4 - 2)) .&. 0x3 in + let s5 = s4 - ((t4 - r4) .&. 256) .>. 7 in + let r5 = r4 - (t4 .&. ((t4 - r4) .>. 8)) in + let t5 = (v .>. fromIntegral (s5 - 1)) .&. 0x1 in + let s6 = s5 - ((t5 - r5) .&. 256) .>. 8 in + fromIntegral s6 + {-# INLINABLE select1 #-} + +instance Select1 [Bool] where + select1 = go 0 + where go r _ 0 = r + go r (True :bs) c = go (r + 1) bs (c - 1) + go r (False:bs) c = go (r + 1) bs c + go _ [] _ = error "Out of range" + {-# INLINABLE select1 #-} + +instance Select1 [Word8] where + select1 v c = go v c 0 + where go :: [Word8] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select1 #-} + +instance Select1 [Word16] where + select1 v c = go v c 0 + where go :: [Word16] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select1 #-} + +instance Select1 [Word32] where + select1 v c = go v c 0 + where go :: [Word32] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select1 #-} + +instance Select1 [Word64] where + select1 v c = go v c 0 + where go :: [Word64] -> Count -> Count -> Count + go _ 0 acc = acc + go u d acc = let w = head u in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (tail u) (d - pc) (acc + elemFixedBitSize u) + {-# INLINABLE select1 #-} + +instance Select1 (DVS.Vector Word8) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DVS.Vector Word16) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DVS.Vector Word32) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DVS.Vector Word64) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DV.Vector Word8) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DV.Vector Word16) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DV.Vector Word32) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} + +instance Select1 (DV.Vector Word64) where + select1 v c = go 0 c 0 + where go _ 0 acc = acc + go n d acc = let w = (v !!! n) in + case popCount1 w of + pc | d <= pc -> select1 w d + acc + pc -> go (n + 1) (d - pc) (acc + elemFixedBitSize v) + {-# INLINABLE select1 #-} diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Poppy512.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Poppy512.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Binary/Poppy512.hs @@ -0,0 +1,55 @@ +module HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 + ( Poppy512(..) + , Rank1(..) + , makePoppy512 + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Search +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Vector.VectorLike + +data Poppy512 = Poppy512 + { poppy512Bits :: DVS.Vector Word64 + , poppy512Index :: DVS.Vector Word64 + } deriving (Eq, Show) + +makePoppy512 :: DVS.Vector Word64 -> Poppy512 +makePoppy512 v = Poppy512 + { poppy512Bits = v + , poppy512Index = DVS.constructN (((DVS.length v + 7) `div` 8) + 1) gen512Index + } + where gen512Index u = let indexN = DVS.length u - 1 in + if indexN == -1 + then 0 + else getCount (popCount1 (DVS.take 8 (DVS.drop (indexN * 8) v))) + DVS.last u + +instance BitRead Poppy512 where + bitRead = fmap makePoppy512 . bitRead + +instance Rank1 Poppy512 where + rank1 (Poppy512 v i) p = + Count (i !!! toPosition (p `div` 512)) + rank1 (DVS.drop (fromIntegral p `div` 512) v) (p `mod` 512) + +instance Rank0 Poppy512 where + rank0 (Poppy512 v i) p = + p `div` 512 * 512 - Count (i !!! toPosition (p `div` 512)) + rank0 (DVS.drop (fromIntegral p `div` 512) v) (p `mod` 512) + +instance Select1 Poppy512 where + select1 (Poppy512 v i) p = toCount q * 512 + select1 (DVS.drop (fromIntegral q * 8) v) (p - s) + where q = binarySearch (fromIntegral p) wordAt 0 (fromIntegral $ DVS.length i - 1) + s = Count (i !!! q) + wordAt = (i !!!) + +instance Select0 Poppy512 where + select0 (Poppy512 v i) p = toCount q * 512 + select0 (DVS.drop (fromIntegral q * 8) v) (p - s) + where q = binarySearch (fromIntegral p) wordAt 0 (fromIntegral $ DVS.length i - 1) + s = Count (fromIntegral q * 512 - (i !!! q)) + wordAt o = fromIntegral o * 512 - (i !!! o) diff --git a/src/HaskellWorks/Data/Succinct/RankSelect/Internal.hs b/src/HaskellWorks/Data/Succinct/RankSelect/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Succinct/RankSelect/Internal.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Succinct.RankSelect.Internal + ( -- * Rank & Select + Rank(..) + , Select(..) + ) where + +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic + +class Eq a => Rank v a where + rank :: a -> v -> Count -> Count + +class Eq a => Select v a where + select :: a -> v -> Count -> Count + +instance Rank [Bool] Bool where + rank a = if a then rank1 else rank0 + {-# INLINABLE rank #-} + +instance Select [Bool] Bool where + select a = if a then select1 else select0 + {-# INLINABLE select #-} diff --git a/src/HaskellWorks/Data/Time.hs b/src/HaskellWorks/Data/Time.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Time.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE BangPatterns #-} + +module HaskellWorks.Data.Time where + +import System.CPUTime + +measure :: a -> IO a +measure a = do + start <- getCPUTime + let !b = a + end <- getCPUTime + print (end - start) + return b diff --git a/src/HaskellWorks/Data/Vector/BoxedVectorLike.hs b/src/HaskellWorks/Data/Vector/BoxedVectorLike.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Vector/BoxedVectorLike.hs @@ -0,0 +1,68 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Vector/Storable/ByteString.hs @@ -0,0 +1,38 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Vector/StorableVectorLike.hs @@ -0,0 +1,68 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Vector/VectorLike.hs @@ -0,0 +1,453 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Word.hs @@ -0,0 +1,40 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Function.hs @@ -0,0 +1,6 @@ +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/BitReadSpec.hs b/test/HaskellWorks/Data/Bits/BitReadSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/BitReadSpec.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.BitReadSpec (spec) where + +import qualified Data.Vector as DV +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitShow +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.BitReadSpec" $ do + it "bitRead \"10000000 101\" :: Maybe [Word8]" $ + let w = bitRead "10000000 101" :: Maybe [Bool] in + w `shouldBe` Just [True, False, False, False, False, False, False, False, True, False, True] + it "bitRead \"10000000 101\" :: Maybe [Word8]"$ + let w = bitRead "10000000 101" :: Maybe [Word8] in + w `shouldBe` Just [1, 5] + it "bitRead \"11100100 10101111 1\" :: Maybe [Word8]" $ + let ws = bitRead "11100100 10101111 1" :: Maybe [Word8] in + ws `shouldBe` Just [39, 245, 1] + it "bitRead \"\" :: Maybe [Word8]" $ + let ws = bitRead "" :: Maybe [Word8] in + ws `shouldBe` Just [] + it "bitRead \"10000000 101\" :: Maybe (DV.Vector Word8)" $ + let v = bitRead "10000000 101" :: Maybe (DV.Vector Word8) in + v `shouldBe` Just (DV.fromList [1, 5]) + it "bitRead \"11100100 10101111 1\" :: Maybe (DV.Vector Word8)" $ + let v = bitRead "11100100 10101111 1" :: Maybe (DV.Vector Word8) in + v `shouldBe` Just (DV.fromList [39, 245, 1]) + it "bitRead \"11100100 10101111 1\" :: Maybe (DV.Vector Word16)" $ + let v = bitRead "11100100 10101111 1" :: Maybe (DV.Vector Word16) in + v `shouldBe` Just (DV.fromList [39 + 62720, 1]) + it "bitRead \"\" :: Maybe (DV.Vector Word8)" $ + let v = bitRead "" :: Maybe (DV.Vector Word8) in + v `shouldBe` Just (DV.fromList []) + it "bitShow (8 :: Word8)" $ + let bs = bitShow (8 :: Word8) in + bs `shouldBe` "00010000" + it "bitShow (8 :: Word64)" $ + let bs = bitShow (8 :: Word64) in + bs `shouldBe` "00010000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + it "bitShow [0x0102040810204080 :: Word64]" $ + let bs = bitShow [0x0102040810204080 :: Word64] in + bs `shouldBe` "00000001 00000010 00000100 00001000 00010000 00100000 01000000 10000000" diff --git a/test/HaskellWorks/Data/Bits/BitWiseSpec.hs b/test/HaskellWorks/Data/Bits/BitWiseSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/BitWiseSpec.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Bits.BitWiseSpec (spec) where + +import qualified Data.Bits as B +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.PopCount.PopCount0 +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.SuccinctSpec" $ do + describe "for popCount0" $ do + it "for Word8 matches Data.Bits implementation" $ property $ + \(w :: Word8 ) -> popCount0 w == bitLength w - fromIntegral (B.popCount w) + it "for Word16 matches Data.Bits implementation" $ property $ + \(w :: Word16) -> popCount0 w == bitLength w - fromIntegral (B.popCount w) + it "for Word32 matches Data.Bits implementation" $ property $ + \(w :: Word32) -> popCount0 w == bitLength w - fromIntegral (B.popCount w) + it "for Word64 matches Data.Bits implementation" $ property $ + \(w :: Word64) -> popCount0 w == bitLength w - fromIntegral (B.popCount w) + it "for [Word8] matches Data.Bits implementation" $ property $ + \(w :: [Word8] ) -> popCount0 w == bitLength w - sum (fmap (fromIntegral . B.popCount) w) + it "for [Word16] matches Data.Bits implementation" $ property $ + \(w :: [Word16]) -> popCount0 w == bitLength w - sum (fmap (fromIntegral . B.popCount) w) + it "for [Word32] matches Data.Bits implementation" $ property $ + \(w :: [Word32]) -> popCount0 w == bitLength w - sum (fmap (fromIntegral . B.popCount) w) + it "for [Word64] matches Data.Bits implementation" $ property $ + \(w :: [Word64]) -> popCount0 w == bitLength w - sum (fmap (fromIntegral . B.popCount) w) + it "for [Word8] matches Data.Bits implementation" $ property $ + \(w :: [Word8] ) -> popCount0 w == popCount0 (DVS.fromList w) + it "for [Word16] matches Data.Bits implementation" $ property $ + \(w :: [Word16]) -> popCount0 w == popCount0 (DVS.fromList w) + it "for [Word32] matches Data.Bits implementation" $ property $ + \(w :: [Word32]) -> popCount0 w == popCount0 (DVS.fromList w) + it "for [Word64] matches Data.Bits implementation" $ property $ + \(w :: [Word64]) -> popCount0 w == popCount0 (DVS.fromList w) + describe "for popCount1" $ do + it "for Word8 matches Data.Bits implementation" $ property $ + \(w :: Word8 ) -> popCount1 w == fromIntegral (B.popCount w) + it "for Word16 matches Data.Bits implementation" $ property $ + \(w :: Word16) -> popCount1 w == fromIntegral (B.popCount w) + it "for Word32 matches Data.Bits implementation" $ property $ + \(w :: Word32) -> popCount1 w == fromIntegral (B.popCount w) + it "for Word64 matches Data.Bits implementation" $ property $ + \(w :: Word64) -> popCount1 w == fromIntegral (B.popCount w) + it "for [Word8] matches Data.Bits implementation" $ property $ + \(w :: [Word8] ) -> popCount1 w == sum (fmap (fromIntegral . B.popCount) w) + it "for [Word16] matches Data.Bits implementation" $ property $ + \(w :: [Word16]) -> popCount1 w == sum (fmap (fromIntegral . B.popCount) w) + it "for [Word32] matches Data.Bits implementation" $ property $ + \(w :: [Word32]) -> popCount1 w == sum (fmap (fromIntegral . B.popCount) w) + it "for [Word64] matches Data.Bits implementation" $ property $ + \(w :: [Word64]) -> popCount1 w == sum (fmap (fromIntegral . B.popCount) w) + it "for [Word8] matches Data.Bits implementation" $ property $ + \(w :: [Word8] ) -> popCount1 w == popCount1 (DVS.fromList w) + it "for [Word16] matches Data.Bits implementation" $ property $ + \(w :: [Word16]) -> popCount1 w == popCount1 (DVS.fromList w) + it "for [Word32] matches Data.Bits implementation" $ property $ + \(w :: [Word32]) -> popCount1 w == popCount1 (DVS.fromList w) + it "for [Word64] matches Data.Bits implementation" $ property $ + \(w :: [Word64]) -> popCount1 w == popCount1 (DVS.fromList w) diff --git a/test/HaskellWorks/Data/Bits/FromBoolsSpec.hs b/test/HaskellWorks/Data/Bits/FromBoolsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Bits/FromBoolsSpec.hs @@ -0,0 +1,157 @@ +{-# 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/Json/BlankSpec.hs b/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Conduit.Json.BlankSpec (spec) where + +import qualified Data.ByteString as BS +import HaskellWorks.Data.Conduit.Json.Blank +import HaskellWorks.Data.Conduit.List +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +whenBlankedJsonShouldBe :: BS.ByteString -> BS.ByteString -> Spec +whenBlankedJsonShouldBe original expected = do + it (show original ++ " when blanked json should be " ++ show expected) $ do + BS.concat (runListConduit blankJson [original]) `shouldBe` expected + +spec :: Spec +spec = describe "HaskellWorks.Data.Conduit.Json.BlankSpec" $ do + describe "Can blank json" $ do + "\"\"" `whenBlankedJsonShouldBe` "()" + "\"\\\\\"" `whenBlankedJsonShouldBe` "( )" + "\"\\\\\\\"" `whenBlankedJsonShouldBe` "( " + "\" \\\\\\\"" `whenBlankedJsonShouldBe` "( " + "\" \\n\\\\\"" `whenBlankedJsonShouldBe` "( )" + "" `whenBlankedJsonShouldBe` "" + "\"\"" `whenBlankedJsonShouldBe` "()" + "\" \"" `whenBlankedJsonShouldBe` "( )" + "\" a \"" `whenBlankedJsonShouldBe` "( )" + " \"a \" x" `whenBlankedJsonShouldBe` " ( ) x" + " \"a\"b\"c\"d" `whenBlankedJsonShouldBe` " ( )b( )d" + "" `whenBlankedJsonShouldBe` "" + "1" `whenBlankedJsonShouldBe` "1" + "11" `whenBlankedJsonShouldBe` "10" + "00" `whenBlankedJsonShouldBe` "10" + "00" `whenBlankedJsonShouldBe` "10" + "-0.12e+34" `whenBlankedJsonShouldBe` "100000000" + "10.12E-34 " `whenBlankedJsonShouldBe` "100000000 " + "10.12E-34 12" `whenBlankedJsonShouldBe` "100000000 10" + " 10.12E-34 -1" `whenBlankedJsonShouldBe` " 100000000 10" + "" `whenBlankedJsonShouldBe` "" + "a" `whenBlankedJsonShouldBe` "a" + "z" `whenBlankedJsonShouldBe` "z" + " Aaa " `whenBlankedJsonShouldBe` " A__ " + " Za def " `whenBlankedJsonShouldBe` " Z_ d__ " + "" `whenBlankedJsonShouldBe` "" + " { \"ff\": 1.0, [\"\", true], null}" `whenBlankedJsonShouldBe` " { ( ): 100, [(), t___], n___}" diff --git a/test/HaskellWorks/Data/Conduit/JsonSpec.hs b/test/HaskellWorks/Data/Conduit/JsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/JsonSpec.hs @@ -0,0 +1,108 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/LineColumnSpec.hs @@ -0,0 +1,171 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/Tokenize/Attoparsec/OffsetSpec.hs @@ -0,0 +1,164 @@ +{-# 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/Final/TokenizeSpec.hs b/test/HaskellWorks/Data/Json/Final/TokenizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Final/TokenizeSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Json.Final.TokenizeSpec (spec) where + +import qualified Data.Attoparsec.ByteString.Char8 as BC +import Data.ByteString as BS +import HaskellWorks.Data.Json.Final.Tokenize +import HaskellWorks.Data.Json.Token +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +parseJsonToken' :: ByteString -> Either String JsonToken +parseJsonToken' = BC.parseOnly parseJsonToken + +spec :: Spec +spec = describe "Data.Conduit.Succinct.JsonSpec" $ do + describe "When parsing single token at beginning of text" $ do + it "Empty Json should produce no bits" $ + parseJsonToken' "" `shouldBe` Left "not enough input" + it "Json with one space should produce whitespace token" $ + parseJsonToken' " " `shouldBe` Right JsonTokenWhitespace + it "Json with two spaces should produce whitespace token" $ + parseJsonToken' " " `shouldBe` Right JsonTokenWhitespace + it "Spaces and newlines should produce no bits" $ + parseJsonToken' " \n \r \t " `shouldBe` Right JsonTokenWhitespace + it "`null` at beginning should produce one bit" $ + parseJsonToken' "null " `shouldBe` Right JsonTokenNull + it "number at beginning should produce one bit" $ + parseJsonToken' "1234 " `shouldBe` Right (JsonTokenNumber 1234) + it "false at beginning should produce one bit" $ + parseJsonToken' "false " `shouldBe` Right (JsonTokenBoolean False) + it "true at beginning should produce one bit" $ + parseJsonToken' "true " `shouldBe` Right (JsonTokenBoolean True) + it "string at beginning should produce one bit" $ + parseJsonToken' "\"hello\" " `shouldBe` Right (JsonTokenString "hello") + it "quoted string should parse" $ + parseJsonToken' "\"\\\"\" " `shouldBe` Right (JsonTokenString "\"") + it "left brace at beginning should produce one bit" $ + parseJsonToken' "{ " `shouldBe` Right JsonTokenBraceL + it "right brace at beginning should produce one bit" $ + parseJsonToken' "} " `shouldBe` Right JsonTokenBraceR + it "left bracket at beginning should produce one bit" $ + parseJsonToken' "[ " `shouldBe` Right JsonTokenBracketL + it "right bracket at beginning should produce one bit" $ + parseJsonToken' "] " `shouldBe` Right JsonTokenBracketR + it "right bracket at beginning should produce one bit" $ + parseJsonToken' ": " `shouldBe` Right JsonTokenColon + it "right bracket at beginning should produce one bit" $ + parseJsonToken' ", " `shouldBe` Right JsonTokenComma diff --git a/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs b/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Json.Succinct.CursorSpec(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.BitShow +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.Json.Succinct.Cursor as C +import HaskellWorks.Data.Json.Token +import qualified HaskellWorks.Data.Succinct.BalancedParens.Internal as BP +import HaskellWorks.Data.Succinct.BalancedParens.Simple +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 +import System.IO.MMap +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: redundant bracket" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do + let fc = C.firstChild + let ns = C.nextSibling + let cd = C.depth + describe "Cursor for [Bool]" $ do + it "initialises to beginning of empty object" $ do + let cursor = "{}" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of empty object preceded by spaces" $ do + let cursor = " {}" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of number" $ do + let cursor = "1234" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorNumber + it "initialises to beginning of string" $ do + let cursor = "\"Hello\"" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorString + it "initialises to beginning of array" $ do + let cursor = "[]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorArray + it "initialises to beginning of boolean true" $ do + let cursor = "true" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of boolean false" $ do + let cursor = "false" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of null" $ do + let cursor = "null" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorNull + it "cursor can navigate to first child of array" $ do + let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType (fc cursor) `shouldBe` JsonCursorNull + it "cursor can navigate to second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType ((ns . fc) cursor) `shouldBe` JsonCursorObject + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType ((fc . ns . fc) cursor) `shouldBe` JsonCursorString + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType ((ns . fc . ns . fc) cursor) `shouldBe` JsonCursorNumber + it "depth at top" $ do + let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd cursor `shouldBe` 1 + it "depth at first child of array" $ do + let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd (fc cursor) `shouldBe` 2 + it "depth at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd ((ns . fc) cursor) `shouldBe` 2 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd ((fc . ns . fc) cursor) `shouldBe` 3 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd ((ns . fc . ns . fc) cursor) `shouldBe` 3 + genSpec "DVS.Vector Word8" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) + genSpec "DVS.Vector Word16" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) + genSpec "DVS.Vector Word32" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) + genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "Poppy512" (undefined :: JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) + it "Loads same Json consistentally from different backing vectors" $ do + let cursor8 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)) + let cursor16 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)) + let cursor32 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)) + let cursor64 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + cursorText cursor8 `shouldBe` cursorText cursor16 + cursorText cursor8 `shouldBe` cursorText cursor32 + cursorText cursor8 `shouldBe` cursorText cursor64 + let ic8 = bitShow $ interests cursor8 + let ic16 = bitShow $ interests cursor16 + let ic32 = bitShow $ interests cursor32 + let ic64 = bitShow $ interests cursor64 + ic16 `shouldBeginWith` ic8 + ic32 `shouldBeginWith` ic16 + ic64 `shouldBeginWith` ic32 + +shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO () +shouldBeginWith as bs = take (length bs) as `shouldBe` bs + +genSpec :: forall t u. + ( Eq t + , Show t + , Select1 t + , Eq u + , Show u + , Rank0 u + , Rank1 u + , BP.BalancedParens u + , FromForeignRegion (JsonCursor BS.ByteString t u) + , IsString (JsonCursor BS.ByteString t u) + , HasJsonCursorType (JsonCursor BS.ByteString t u)) + => String -> (JsonCursor BS.ByteString t u) -> SpecWith () +genSpec t _ = do + let fc = C.firstChild + let ns = C.nextSibling + let pn = C.parent + let cd = C.depth + let ss = C.subtreeSize + describe ("Cursor for (" ++ t ++ ")") $ do + it "initialises to beginning of empty object" $ do + let cursor = "{}" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of empty object preceded by spaces" $ do + let cursor = " {}" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of number" $ do + let cursor = "1234" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorNumber + it "initialises to beginning of string" $ do + let cursor = "\"Hello\"" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorString + it "initialises to beginning of array" $ do + let cursor = "[]" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorArray + it "initialises to beginning of boolean true" $ do + let cursor = "true" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of boolean false" $ do + let cursor = "false" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of null" $ do + let cursor = "null" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorNull + it "cursor can navigate to first child of array" $ do + let cursor = "[null]" :: JsonCursor BS.ByteString t u + jsonCursorType (firstChild cursor) `shouldBe` JsonCursorNull + it "cursor can navigate to second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + jsonCursorType ((ns . fc) cursor) `shouldBe` JsonCursorObject + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + jsonCursorType ((fc . ns . fc) cursor) `shouldBe` JsonCursorString + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + jsonCursorType ((ns . fc . ns . fc) cursor) `shouldBe` JsonCursorNumber + it "depth at top" $ do + let cursor = "[null]" :: JsonCursor BS.ByteString t u + cd cursor `shouldBe` 1 + it "depth at first child of array" $ do + let cursor = "[null]" :: JsonCursor BS.ByteString t u + cd (fc cursor) `shouldBe` 2 + it "depth at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + cd ((ns . fc) cursor) `shouldBe` 2 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + cd ((fc . ns . fc) cursor) `shouldBe` 3 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + cd ((ns . fc . ns . fc) cursor) `shouldBe` 3 + it "can navigate down and forwards" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/Resources/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorObject + jsonCursorType (( fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . fc) cursor) `shouldBe` JsonCursorObject + jsonCursorType (( fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorObject + jsonCursorType (( fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType ((ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorNumber + it "can navigate up" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/Resources/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + ( pn . fc) cursor `shouldBe` cursor + ( pn . ns . fc) cursor `shouldBe` cursor + ( pn . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . ns . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . ns . ns . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . ns . ns . ns . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + it "can get subtree size" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/Resources/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + ss cursor `shouldBe` 45 + ss (( fc) cursor) `shouldBe` 1 + ss (( ns . fc) cursor) `shouldBe` 43 + ss (( fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 9 + ss (( fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss ((ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + it "can get token at cursor" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/Resources/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + jsonTokenAt cursor `shouldBe` JsonTokenBraceL + jsonTokenAt (( fc) cursor) `shouldBe` JsonTokenString "widget" + jsonTokenAt (( ns . fc) cursor) `shouldBe` JsonTokenBraceL + jsonTokenAt (( fc . ns . fc) cursor) `shouldBe` JsonTokenString "debug" + jsonTokenAt (( ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "on" + jsonTokenAt (( ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "window" + jsonTokenAt (( ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenBraceL + jsonTokenAt (( fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "title" + jsonTokenAt (( ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "Sample Konfabulator Widget" + jsonTokenAt (( ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "name" + jsonTokenAt (( ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "main_window" + jsonTokenAt (( ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenString "width" + jsonTokenAt ((ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonTokenNumber 500.0 diff --git a/test/HaskellWorks/Data/Json/SuccinctSpec.hs b/test/HaskellWorks/Data/Json/SuccinctSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/SuccinctSpec.hs @@ -0,0 +1,34 @@ +{-# 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") diff --git a/test/HaskellWorks/Data/Succinct/BalancedParensSpec.hs b/test/HaskellWorks/Data/Succinct/BalancedParensSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/BalancedParensSpec.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.BalancedParensSpec where + +import Data.Maybe +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Succinct.BalancedParens +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.BalancedParensSpec" $ do + describe "For (()(()())) 1101101000" $ do + let bs = SimpleBalancedParens (91 :: Word64) + it "Test 1a" $ findClose bs 1 `shouldBe` 10 + it "Test 1b" $ findClose bs 2 `shouldBe` 3 + it "Test 2a" $ findOpen bs 10 `shouldBe` 1 + it "Test 2b" $ findOpen bs 3 `shouldBe` 2 + it "Test 3a" $ enclose bs 2 `shouldBe` 1 + it "Test 3b" $ enclose bs 7 `shouldBe` 4 + describe "For (()(()())) 1101101000" $ do + let bs = SimpleBalancedParens (fromJust (bitRead "1101101000") :: [Bool]) + it "Test 1a" $ findClose bs 1 `shouldBe` 10 + it "Test 1b" $ findClose bs 2 `shouldBe` 3 + it "Test 1b" $ findClose bs 3 `shouldBe` 3 + it "Test 1b" $ findClose bs 4 `shouldBe` 9 + it "Test 2a" $ findOpen bs 10 `shouldBe` 1 + it "Test 2b" $ findOpen bs 3 `shouldBe` 2 + it "Test 3a" $ enclose bs 2 `shouldBe` 1 + it "Test 3b" $ enclose bs 7 `shouldBe` 4 + it "firstChild 1" $ firstChild bs 1 `shouldBe` 2 + it "firstChild 4" $ firstChild bs 4 `shouldBe` 5 + it "nextSibling 2" $ nextSibling bs 2 `shouldBe` 4 + it "nextSibling 5" $ nextSibling bs 5 `shouldBe` 7 + it "parent 2" $ parent bs 2 `shouldBe` 1 + it "parent 5" $ parent bs 5 `shouldBe` 4 + it "depth 1" $ depth bs 1 `shouldBe` 1 + it "depth 2" $ depth bs 2 `shouldBe` 2 + it "depth 3" $ depth bs 3 `shouldBe` 2 + it "depth 4" $ depth bs 4 `shouldBe` 2 + it "depth 5" $ depth bs 5 `shouldBe` 3 + it "depth 6" $ depth bs 6 `shouldBe` 3 + it "depth 7" $ depth bs 7 `shouldBe` 3 + it "depth 8" $ depth bs 8 `shouldBe` 3 + it "depth 9" $ depth bs 9 `shouldBe` 2 + it "depth 10" $ depth bs 10 `shouldBe` 1 + it "subtreeSize 1" $ subtreeSize bs 1 `shouldBe` 5 + it "subtreeSize 2" $ subtreeSize bs 2 `shouldBe` 1 + it "subtreeSize 3" $ subtreeSize bs 3 `shouldBe` 0 + it "subtreeSize 4" $ subtreeSize bs 4 `shouldBe` 3 + it "subtreeSize 5" $ subtreeSize bs 5 `shouldBe` 1 + it "subtreeSize 6" $ subtreeSize bs 6 `shouldBe` 0 + it "subtreeSize 7" $ subtreeSize bs 7 `shouldBe` 1 + it "subtreeSize 8" $ subtreeSize bs 8 `shouldBe` 0 + it "subtreeSize 9" $ subtreeSize bs 9 `shouldBe` 0 + it "subtreeSize 10" $ subtreeSize bs 10 `shouldBe` 0 + describe "For (()(()())) 11011010 00000000 :: DVS.Vector Word8" $ do + let bs = SimpleBalancedParens (fromJust (bitRead "11011010 00000000") :: DVS.Vector Word8) + it "Test 1a" $ findClose bs 1 `shouldBe` 10 + it "Test 1b" $ findClose bs 2 `shouldBe` 3 + it "Test 1b" $ findClose bs 3 `shouldBe` 3 + it "Test 1b" $ findClose bs 4 `shouldBe` 9 + it "Test 2a" $ findOpen bs 10 `shouldBe` 1 + it "Test 2b" $ findOpen bs 3 `shouldBe` 2 + it "Test 3a" $ enclose bs 2 `shouldBe` 1 + it "Test 3b" $ enclose bs 7 `shouldBe` 4 + it "firstChild 1" $ firstChild bs 1 `shouldBe` 2 + it "firstChild 4" $ firstChild bs 4 `shouldBe` 5 + it "nextSibling 2" $ nextSibling bs 2 `shouldBe` 4 + it "nextSibling 5" $ nextSibling bs 5 `shouldBe` 7 + it "parent 2" $ parent bs 2 `shouldBe` 1 + it "parent 5" $ parent bs 5 `shouldBe` 4 + it "depth 1" $ depth bs 1 `shouldBe` 1 + it "depth 2" $ depth bs 2 `shouldBe` 2 + it "depth 3" $ depth bs 3 `shouldBe` 2 + it "depth 4" $ depth bs 4 `shouldBe` 2 + it "depth 5" $ depth bs 5 `shouldBe` 3 + it "depth 6" $ depth bs 6 `shouldBe` 3 + it "depth 7" $ depth bs 7 `shouldBe` 3 + it "depth 8" $ depth bs 8 `shouldBe` 3 + it "depth 9" $ depth bs 9 `shouldBe` 2 + it "depth 10" $ depth bs 10 `shouldBe` 1 + it "subtreeSize 1" $ subtreeSize bs 1 `shouldBe` 5 + it "subtreeSize 2" $ subtreeSize bs 2 `shouldBe` 1 + it "subtreeSize 3" $ subtreeSize bs 3 `shouldBe` 0 + it "subtreeSize 4" $ subtreeSize bs 4 `shouldBe` 3 + it "subtreeSize 5" $ subtreeSize bs 5 `shouldBe` 1 + it "subtreeSize 6" $ subtreeSize bs 6 `shouldBe` 0 + it "subtreeSize 7" $ subtreeSize bs 7 `shouldBe` 1 + it "subtreeSize 8" $ subtreeSize bs 8 `shouldBe` 0 + it "subtreeSize 9" $ subtreeSize bs 9 `shouldBe` 0 + it "subtreeSize 10" $ subtreeSize bs 10 `shouldBe` 0 + +-- 11011010 00000000, cursorRank = 2 diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank0Spec.hs b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank0Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank0Spec.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0Spec + ( genRank0UpTo8Spec + , genRank0UpTo16Spec + , spec + ) where + +import Data.Maybe +import Data.Typeable +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PopCount.PopCount0 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +genRank0UpTo8Spec :: forall s. (Typeable s, BitRead s, Rank0 s) => s -> Spec +genRank0UpTo8Spec _ = describe ("Generically up to 8 bits for " ++ show (typeOf (undefined :: s))) $ do + it "rank0 10010010 over [0..8] should be 001223445" $ do + let bs = fromJust (bitRead "10010010") :: s + fmap (rank0 bs) [0..8] `shouldBe` [0, 0, 1, 2, 2, 3, 4, 4, 5] + +genRank0UpTo16Spec :: forall s. (Typeable s, BitRead s, Rank0 s) => s -> Spec +genRank0UpTo16Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do + it "rank0 11011010 00000000 over [0..16]" $ do + let bs = fromJust $ bitRead "11011010 00000000" :: s + fmap (rank0 bs) [0..16] `shouldBe` [0, 0, 0, 1, 1, 1, 2, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11] + it "rank0 11011010 10000000 over [0..16]" $ do + let bs = fromJust $ bitRead "11011010 10000000" :: s + fmap (rank0 bs) [0..16] `shouldBe` [0, 0, 0, 1, 1, 1, 2, 2, 3, 3, 4, 5, 6, 7, 8, 9, 10] + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.RankSelect.InternalSpec" $ do + genRank0UpTo8Spec (undefined :: Word8) + genRank0UpTo8Spec (undefined :: Word16) + genRank0UpTo8Spec (undefined :: Word32) + genRank0UpTo8Spec (undefined :: Word64) + genRank0UpTo8Spec (undefined :: [Word8]) + genRank0UpTo16Spec (undefined :: [Word8]) + genRank0UpTo8Spec (undefined :: [Word16]) + genRank0UpTo16Spec (undefined :: [Word16]) + genRank0UpTo8Spec (undefined :: [Word32]) + genRank0UpTo16Spec (undefined :: [Word32]) + genRank0UpTo8Spec (undefined :: [Word64]) + genRank0UpTo16Spec (undefined :: [Word64]) + genRank0UpTo8Spec (undefined :: DV.Vector Word8) + genRank0UpTo16Spec (undefined :: DV.Vector Word8) + genRank0UpTo8Spec (undefined :: DV.Vector Word16) + genRank0UpTo16Spec (undefined :: DV.Vector Word16) + genRank0UpTo8Spec (undefined :: DV.Vector Word32) + genRank0UpTo16Spec (undefined :: DV.Vector Word32) + genRank0UpTo8Spec (undefined :: DV.Vector Word64) + genRank0UpTo16Spec (undefined :: DV.Vector Word64) + genRank0UpTo8Spec (undefined :: DVS.Vector Word8) + genRank0UpTo16Spec (undefined :: DVS.Vector Word8) + genRank0UpTo8Spec (undefined :: DVS.Vector Word16) + genRank0UpTo16Spec (undefined :: DVS.Vector Word16) + genRank0UpTo8Spec (undefined :: DVS.Vector Word32) + genRank0UpTo16Spec (undefined :: DVS.Vector Word32) + genRank0UpTo8Spec (undefined :: DVS.Vector Word64) + genRank0UpTo16Spec (undefined :: DVS.Vector Word64) + describe "Different word sizes give the same rank0" $ do + it "when comparing Word16 and Word64 over bits 0-7" $ + forAll (choose (0, 8 :: Count)) $ \(i :: Count) (w :: Word8) -> + rank0 w i == rank0 (fromIntegral w :: Word64) i + it "when comparing Word16 and Word64 over bits 0-15" $ property $ + forAll (choose (0, 16 :: Count)) $ \(i :: Count) (w :: Word16) -> + rank0 w i == rank0 (fromIntegral w :: Word64) i + it "when comparing Word32 and Word64 over bits 0-31" $ property $ + forAll (choose (0, 32 :: Count)) $ \(i :: Count) (w :: Word32) -> + rank0 w i == rank0 (fromIntegral w :: Word64) i + it "when comparing Word32 and Word64 over bits 32-64" $ property $ + forAll (choose (0, 32 :: Count)) $ \(i :: Count) (v :: Word32) (w :: Word32) -> + let v64 = fromIntegral v :: Word64 in + let w64 = fromIntegral w :: Word64 in + rank0 v i + popCount0 w == rank0 ((v64 .<. 32) .|. w64) (i + 32) + it "when comparing select1 for Word64 form a galois connection" $ property $ + forAll (choose (0, 32 :: Count)) $ \(i :: Count) (w :: Word32) -> + 1 <= i && i <= popCount0 w ==> + rank0 w (select0 w i) == i && select0 w (rank0 w (fromIntegral i)) <= fromIntegral i diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank1Spec.hs b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank1Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Rank1Spec.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1Spec + ( genRank1UpTo8Spec + , genRank1UpTo16Spec + , spec + ) where + +import Data.Maybe +import Data.Typeable +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +genRank1UpTo8Spec :: forall s. (Typeable s, BitRead s, Rank1 s) => s -> Spec +genRank1UpTo8Spec _ = describe ("Generically up to 8 bits for " ++ show (typeOf (undefined :: s))) $ do + it "rank1 10010010 over [0..8] should be 011122233" $ do + let bs = fromJust (bitRead "10010010") :: s + fmap (rank1 bs) [0..8] `shouldBe` [0, 1, 1, 1, 2, 2, 2, 3, 3] + +genRank1UpTo16Spec :: forall s. (Typeable s, BitRead s, Rank1 s) => s -> Spec +genRank1UpTo16Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do + it "rank1 11011010 00000000 over [0..9]" $ do + let bs = fromJust $ bitRead "11011010 00000000" :: s + fmap (rank1 bs) [0..16] `shouldBe` [0, 1, 2, 2, 3, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5] + it "rank1 11011010 10000000 over [0..9]" $ do + let bs = fromJust $ bitRead "11011010 10000000" :: s + fmap (rank1 bs) [0..16] `shouldBe` [0, 1, 2, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6] + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.RankSelect.InternalSpec" $ do + genRank1UpTo8Spec (undefined :: Word8) + genRank1UpTo8Spec (undefined :: Word16) + genRank1UpTo8Spec (undefined :: Word32) + genRank1UpTo8Spec (undefined :: Word64) + genRank1UpTo8Spec (undefined :: [Word8]) + genRank1UpTo16Spec (undefined :: [Word8]) + genRank1UpTo8Spec (undefined :: [Word16]) + genRank1UpTo16Spec (undefined :: [Word16]) + genRank1UpTo8Spec (undefined :: [Word32]) + genRank1UpTo16Spec (undefined :: [Word32]) + genRank1UpTo8Spec (undefined :: [Word64]) + genRank1UpTo16Spec (undefined :: [Word64]) + genRank1UpTo8Spec (undefined :: DV.Vector Word8) + genRank1UpTo16Spec (undefined :: DV.Vector Word8) + genRank1UpTo8Spec (undefined :: DV.Vector Word16) + genRank1UpTo16Spec (undefined :: DV.Vector Word16) + genRank1UpTo8Spec (undefined :: DV.Vector Word32) + genRank1UpTo16Spec (undefined :: DV.Vector Word32) + genRank1UpTo8Spec (undefined :: DV.Vector Word64) + genRank1UpTo16Spec (undefined :: DV.Vector Word64) + genRank1UpTo8Spec (undefined :: DVS.Vector Word8) + genRank1UpTo16Spec (undefined :: DVS.Vector Word8) + genRank1UpTo8Spec (undefined :: DVS.Vector Word16) + genRank1UpTo16Spec (undefined :: DVS.Vector Word16) + genRank1UpTo8Spec (undefined :: DVS.Vector Word32) + genRank1UpTo16Spec (undefined :: DVS.Vector Word32) + genRank1UpTo8Spec (undefined :: DVS.Vector Word64) + genRank1UpTo16Spec (undefined :: DVS.Vector Word64) + describe "For Word8-Word64" $ do + it "rank1 for Word16 and Word64 should give same answer for bits 0-7" $ + forAll (choose (0, 8)) $ \(i :: Count) (w :: Word8) -> + rank1 w i == rank1 (fromIntegral w :: Word64) i + it "rank1 for Word16 and Word64 should give same answer for bits 0-15" $ + forAll (choose (0, 16)) $ \(i :: Count) (w :: Word16) -> + rank1 w i == rank1 (fromIntegral w :: Word64) i + it "rank1 for Word32 and Word64 should give same answer for bits 0-31" $ + forAll (choose (0, 32)) $ \(i :: Count) (w :: Word32) -> + rank1 w i == rank1 (fromIntegral w :: Word64) i + it "rank1 for Word32 and Word64 should give same answer for bits 32-64" $ + forAll (choose (0, 32)) $ \(i :: Count) (v :: Word32) (w :: Word32) -> + let v64 = fromIntegral v :: Word64 in + let w64 = fromIntegral w :: Word64 in + rank1 v i + popCount1 w == rank1 ((v64 .<. 32) .|. w64) (i + 32) + it "rank1 and select1 for Word64 form a galois connection" $ + forAll (choose (0, 32)) $ \(i :: Count) (w :: Word32) -> 1 <= i && i <= popCount1 w ==> + rank1 w (select1 w i) == i && select1 w (rank1 w (fromIntegral i)) <= fromIntegral i diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select0Spec.hs b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select0Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select0Spec.hs @@ -0,0 +1,116 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0Spec + ( genSelect0UpTo8Spec + , genSelect0UpTo16Spec + , genSelect0UpTo32Spec + , spec + ) where + +import Data.Maybe +import Data.Typeable +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PopCount.PopCount0 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +genSelect0UpTo8Spec :: forall s. (Typeable s, BitRead s, Select0 s) => s -> Spec +genSelect0UpTo8Spec _ = describe ("Generically up to 8 bits for " ++ show (typeOf (undefined :: s))) $ do + it "select0 10010010 over [0..5] should be 023568" $ do + let bs = fromJust $ bitRead "10010010" :: Word8 + fmap (select0 bs) [0..5] `shouldBe` [0, 2, 3, 5, 6, 8] + +genSelect0UpTo16Spec :: forall s. (Typeable s, BitRead s, Select0 s) => s -> Spec +genSelect0UpTo16Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do + it "select0 11011010 00 over [0..5]" $ + let bs = fromJust $ bitRead "1101101 000" :: [Bool] in + fmap (select0 bs) [0..5] `shouldBe` [0, 3, 6, 8, 9, 10] + it "select0 11011010 00000000 over [0..5]" $ do + let bs = fromJust $ bitRead "11011010 00000000" :: Word32 + fmap (select0 bs) [0..11] `shouldBe` [0, 3, 6, 8, 9, 10, 11, 12, 13, 14, 15, 16] + +genSelect0UpTo32Spec :: forall s. (Typeable s, BitRead s, Select0 s) => s -> Spec +genSelect0UpTo32Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do + it "select0 11000001 10000000 01000000 over [0..5] should be 023568" $ + let bs = fromJust $ bitRead "11000001 10000000 01000000" :: s in + fmap (select0 bs) [0..19] `shouldBe` [0, 3, 4, 5, 6, 7, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 21, 22, 23, 24] + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.RankSelect.InternalSpec" $ do + genSelect0UpTo8Spec (undefined :: Word8) + genSelect0UpTo8Spec (undefined :: Word16) + genSelect0UpTo8Spec (undefined :: Word32) + genSelect0UpTo8Spec (undefined :: Word64) + genSelect0UpTo16Spec (undefined :: Word16) + genSelect0UpTo16Spec (undefined :: Word32) + genSelect0UpTo16Spec (undefined :: Word64) + genSelect0UpTo32Spec (undefined :: Word32) + genSelect0UpTo32Spec (undefined :: Word64) + genSelect0UpTo8Spec (undefined :: [Bool]) + genSelect0UpTo16Spec (undefined :: [Bool]) + genSelect0UpTo32Spec (undefined :: [Bool]) + genSelect0UpTo8Spec (undefined :: [Word8]) + genSelect0UpTo16Spec (undefined :: [Word8]) + genSelect0UpTo32Spec (undefined :: [Word8]) + genSelect0UpTo8Spec (undefined :: [Word16]) + genSelect0UpTo16Spec (undefined :: [Word16]) + genSelect0UpTo32Spec (undefined :: [Word16]) + genSelect0UpTo8Spec (undefined :: [Word32]) + genSelect0UpTo16Spec (undefined :: [Word32]) + genSelect0UpTo32Spec (undefined :: [Word32]) + genSelect0UpTo8Spec (undefined :: [Word64]) + genSelect0UpTo16Spec (undefined :: [Word64]) + genSelect0UpTo32Spec (undefined :: [Word64]) + genSelect0UpTo8Spec (undefined :: DV.Vector Word8) + genSelect0UpTo16Spec (undefined :: DV.Vector Word8) + genSelect0UpTo32Spec (undefined :: DV.Vector Word8) + genSelect0UpTo8Spec (undefined :: DV.Vector Word16) + genSelect0UpTo16Spec (undefined :: DV.Vector Word16) + genSelect0UpTo32Spec (undefined :: DV.Vector Word16) + genSelect0UpTo8Spec (undefined :: DV.Vector Word32) + genSelect0UpTo16Spec (undefined :: DV.Vector Word32) + genSelect0UpTo32Spec (undefined :: DV.Vector Word32) + genSelect0UpTo8Spec (undefined :: DV.Vector Word64) + genSelect0UpTo16Spec (undefined :: DV.Vector Word64) + genSelect0UpTo32Spec (undefined :: DV.Vector Word64) + genSelect0UpTo8Spec (undefined :: DVS.Vector Word8) + genSelect0UpTo16Spec (undefined :: DVS.Vector Word8) + genSelect0UpTo32Spec (undefined :: DVS.Vector Word8) + genSelect0UpTo8Spec (undefined :: DVS.Vector Word16) + genSelect0UpTo16Spec (undefined :: DVS.Vector Word16) + genSelect0UpTo32Spec (undefined :: DVS.Vector Word16) + genSelect0UpTo8Spec (undefined :: DVS.Vector Word32) + genSelect0UpTo16Spec (undefined :: DVS.Vector Word32) + genSelect0UpTo32Spec (undefined :: DVS.Vector Word32) + genSelect0UpTo8Spec (undefined :: DVS.Vector Word64) + genSelect0UpTo16Spec (undefined :: DVS.Vector Word64) + genSelect0UpTo32Spec (undefined :: DVS.Vector Word64) + describe "For Word8-Word64" $ do + it "rank0 for Word16 and Word64 should give same answer for bits 0-7" $ + forAll (choose (0, 8)) $ \(i :: Count) (w :: Word8) -> + rank0 w i == rank0 (fromIntegral w :: Word64) i + it "rank0 for Word16 and Word64 should give same answer for bits 0-15" $ + forAll (choose (0, 16)) $ \(i :: Count) (w :: Word16) -> + rank0 w i == rank0 (fromIntegral w :: Word64) i + it "rank0 for Word32 and Word64 should give same answer for bits 0-31" $ + forAll (choose (0, 32)) $ \(i :: Count) (w :: Word32) -> + rank0 w i == rank0 (fromIntegral w :: Word64) i + it "rank0 for Word32 and Word64 should give same answer for bits 32-64" $ + forAll (choose (0, 32)) $ \(i :: Count) (v :: Word32) (w :: Word32) -> + let v64 = fromIntegral v :: Word64 in + let w64 = fromIntegral w :: Word64 in + rank0 v i + popCount0 w == rank0 ((v64 .<. 32) .|. w64) (i + 32) + it "rank0 and select0 for Word64 form a galois connection" $ property $ + forAll (choose (0, 32)) $ \(i :: Count) (w :: Word32) -> 1 <= i && i <= popCount0 w ==> + rank0 w (select0 w i) == i && select0 w (rank0 w (fromIntegral i)) <= fromIntegral i diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select1Spec.hs b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select1Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Basic/Select1Spec.hs @@ -0,0 +1,122 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1Spec + ( genSelect1UpTo8Spec + , genSelect1UpTo16Spec + , genSelect1UpTo32Spec + , spec + ) where + +import Data.Maybe +import Data.Typeable +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +genSelect1UpTo8Spec :: forall s. (Typeable s, BitRead s, Select1 s) => s -> Spec +genSelect1UpTo8Spec _ = describe ("Generically up to 8 bits for " ++ show (typeOf (undefined :: s))) $ do + it "select1 10010010 over [0..3] should be 0147" $ do + let bs = fromJust $ bitRead "10010010" :: s + fmap (select1 bs) [0..3] `shouldBe` [0, 1, 4, 7] + +genSelect1UpTo16Spec :: forall s. (Typeable s, BitRead s, Select1 s) => s -> Spec +genSelect1UpTo16Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do + it "select1 11011010 00 over [0..5]" $ + let bs = fromJust $ bitRead "11011010 00" :: s in + fmap (select1 bs) [0..5] `shouldBe` [0, 1, 2, 4, 5, 7] + it "select1 11011010 00000000 over [0..5]" $ do + let bs = fromJust $ bitRead "11011010 00000000" :: s + fmap (select1 bs) [0..5] `shouldBe` [0, 1, 2, 4, 5, 7] + it "select 01000000 00000100 over [0..2]" $ do + let bs = fromJust $ bitRead "01000000 00000100" :: s + fmap (select1 bs) [0..2] `shouldBe` [0, 2, 14] + +genSelect1UpTo32Spec :: forall s. (Typeable s, BitRead s, Select1 s) => s -> Spec +genSelect1UpTo32Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do + it "select1 11000001 10000000 01000000 over [0..5] should be 023568" $ + let bs = fromJust $ bitRead "11000001 10000000 01000000" :: s in + fmap (select1 bs) [0..5] `shouldBe` [0, 1, 2, 8, 9, 18] + it "select 10000010 00000000 00100000 00010000 over [0..4]" $ do + let bs = fromJust $ bitRead "10000010 00000000 00100000 00010000" :: s + fmap (select1 bs) [0..4] `shouldBe` [0, 1, 7, 19, 28] + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.RankSelect.InternalSpec" $ do + genSelect1UpTo8Spec (undefined :: Word8) + genSelect1UpTo8Spec (undefined :: Word16) + genSelect1UpTo8Spec (undefined :: Word32) + genSelect1UpTo8Spec (undefined :: Word64) + genSelect1UpTo16Spec (undefined :: Word16) + genSelect1UpTo16Spec (undefined :: Word32) + genSelect1UpTo16Spec (undefined :: Word64) + genSelect1UpTo32Spec (undefined :: Word32) + genSelect1UpTo32Spec (undefined :: Word64) + genSelect1UpTo8Spec (undefined :: [Bool]) + genSelect1UpTo16Spec (undefined :: [Bool]) + genSelect1UpTo32Spec (undefined :: [Bool]) + genSelect1UpTo8Spec (undefined :: [Word8]) + genSelect1UpTo16Spec (undefined :: [Word8]) + genSelect1UpTo32Spec (undefined :: [Word8]) + genSelect1UpTo8Spec (undefined :: [Word16]) + genSelect1UpTo16Spec (undefined :: [Word16]) + genSelect1UpTo32Spec (undefined :: [Word16]) + genSelect1UpTo8Spec (undefined :: [Word32]) + genSelect1UpTo16Spec (undefined :: [Word32]) + genSelect1UpTo32Spec (undefined :: [Word32]) + genSelect1UpTo8Spec (undefined :: [Word64]) + genSelect1UpTo16Spec (undefined :: [Word64]) + genSelect1UpTo32Spec (undefined :: [Word64]) + genSelect1UpTo8Spec (undefined :: DV.Vector Word8) + genSelect1UpTo16Spec (undefined :: DV.Vector Word8) + genSelect1UpTo32Spec (undefined :: DV.Vector Word8) + genSelect1UpTo8Spec (undefined :: DV.Vector Word16) + genSelect1UpTo16Spec (undefined :: DV.Vector Word16) + genSelect1UpTo32Spec (undefined :: DV.Vector Word16) + genSelect1UpTo8Spec (undefined :: DV.Vector Word32) + genSelect1UpTo16Spec (undefined :: DV.Vector Word32) + genSelect1UpTo32Spec (undefined :: DV.Vector Word32) + genSelect1UpTo8Spec (undefined :: DV.Vector Word64) + genSelect1UpTo16Spec (undefined :: DV.Vector Word64) + genSelect1UpTo32Spec (undefined :: DV.Vector Word64) + genSelect1UpTo8Spec (undefined :: DVS.Vector Word8) + genSelect1UpTo16Spec (undefined :: DVS.Vector Word8) + genSelect1UpTo32Spec (undefined :: DVS.Vector Word8) + genSelect1UpTo8Spec (undefined :: DVS.Vector Word16) + genSelect1UpTo16Spec (undefined :: DVS.Vector Word16) + genSelect1UpTo32Spec (undefined :: DVS.Vector Word16) + genSelect1UpTo8Spec (undefined :: DVS.Vector Word32) + genSelect1UpTo16Spec (undefined :: DVS.Vector Word32) + genSelect1UpTo32Spec (undefined :: DVS.Vector Word32) + genSelect1UpTo8Spec (undefined :: DVS.Vector Word64) + genSelect1UpTo16Spec (undefined :: DVS.Vector Word64) + genSelect1UpTo32Spec (undefined :: DVS.Vector Word64) + describe "For Word64" $ do + it "rank1 for Word16 and Word64 should give same answer for bits 0-7" $ property $ + forAll (choose (0, 8)) $ \(i :: Count) (w :: Word8) -> + rank1 w i == rank1 (fromIntegral w :: Word64) i + it "rank1 for Word16 and Word64 should give same answer for bits 0-15" $ property $ + forAll (choose (0, 16)) $ \(i :: Count) (w :: Word16) -> + rank1 w i == rank1 (fromIntegral w :: Word64) i + it "rank1 for Word32 and Word64 should give same answer for bits 0-31" $ property $ + forAll (choose (0, 32)) $ \(i :: Count) (w :: Word32) -> + rank1 w i == rank1 (fromIntegral w :: Word64) i + it "rank1 for Word32 and Word64 should give same answer for bits 32-64" $ property $ + forAll (choose (0, 32)) $ \(i :: Count) (v :: Word32) (w :: Word32) -> + let v64 = fromIntegral v :: Word64 in + let w64 = fromIntegral w :: Word64 in + rank1 v i + popCount1 w == rank1 ((v64 .<. 32) .|. w64) (i + 32) + it "rank1 and select1 for Word64 form a galois connection" $ property $ + forAll (choose (0, 32)) $ \(i :: Count) (w :: Word32) -> 1 <= i && i <= popCount1 w ==> + rank1 w (select1 w i) == i && select1 w (rank1 w (fromIntegral i)) <= fromIntegral i diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/Binary/BasicGen.hs b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/BasicGen.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/BasicGen.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.BasicGen + ( genBinaryRankSelectSpec + ) where + +import Data.Typeable +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0Spec hiding (spec) +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1Spec hiding (spec) +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0Spec hiding (spec) +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1Spec hiding (spec) +import Test.Hspec + +genBinaryRankSelectSpec :: forall s. (Typeable s, BitRead s, Rank0 s, Rank1 s, Select0 s, Select1 s) => s -> Spec +genBinaryRankSelectSpec s = describe "Generically" $ do + genRank0UpTo8Spec s + genRank0UpTo16Spec s + genRank1UpTo8Spec s + genRank1UpTo16Spec s + genSelect0UpTo8Spec s + genSelect0UpTo16Spec s + genSelect0UpTo32Spec s + genSelect1UpTo8Spec s + genSelect1UpTo16Spec s + genSelect1UpTo32Spec s diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Poppy512Spec.hs b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Poppy512Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/Binary/Poppy512Spec.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512Spec (spec) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.PopCount.PopCount0 +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.BasicGen +import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 +import HaskellWorks.Data.Vector.VectorLike +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +newtype ShowVector a = ShowVector a deriving (Eq, BitShow) + +instance BitShow a => Show (ShowVector a) where + show = bitShow + +vectorSizedBetween :: Int -> Int -> Gen (ShowVector (DVS.Vector Word64)) +vectorSizedBetween a b = do + n <- choose (a, b) + xs <- sequence [ arbitrary | _ <- [1 .. n] ] + return $ ShowVector (DVS.fromList xs) + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512.Rank1Spec" $ do + genBinaryRankSelectSpec (undefined :: Poppy512) + describe "rank1 for Vector Word64 is equivalent to rank1 for Poppy512" $ do + it "on empty bitvector" $ + let v = DVS.empty in + let w = makePoppy512 v in + let i = 0 in + rank1 v i === rank1 w i + it "on one basic block" $ + forAll (vectorSizedBetween 1 8) $ \(ShowVector v) -> + forAll (choose (0, vLength v * 8)) $ \i -> + let w = makePoppy512 v in + rank1 v i === rank1 w i + it "on two basic blocks" $ + forAll (vectorSizedBetween 9 16) $ \(ShowVector v) -> + forAll (choose (0, vLength v * 8)) $ \i -> + let w = makePoppy512 v in + rank1 v i === rank1 w i + it "on three basic blocks" $ + forAll (vectorSizedBetween 17 24) $ \(ShowVector v) -> + forAll (choose (0, vLength v * 8)) $ \i -> + let w = makePoppy512 v in + rank1 v i === rank1 w i + describe "rank0 for Vector Word64 is equivalent to rank0 for Poppy512" $ do + it "on empty bitvector" $ + let v = DVS.empty in + let w = makePoppy512 v in + let i = 0 in + rank0 v i === rank0 w i + it "on one basic block" $ + forAll (vectorSizedBetween 1 8) $ \(ShowVector v) -> + forAll (choose (0, vLength v * 8)) $ \i -> + let w = makePoppy512 v in + rank0 v i === rank0 w i + it "on two basic blocks" $ + forAll (vectorSizedBetween 9 16) $ \(ShowVector v) -> + forAll (choose (0, vLength v * 8)) $ \i -> + let w = makePoppy512 v in + rank0 v i === rank0 w i + it "on three basic blocks" $ + forAll (vectorSizedBetween 17 24) $ \(ShowVector v) -> + forAll (choose (0, vLength v * 8)) $ \i -> + let w = makePoppy512 v in + rank0 v i === rank0 w i + describe "select0 for Vector Word64 is equivalent to select0 for Poppy512" $ do + it "on empty bitvector" $ + let v = DVS.empty in + let w = makePoppy512 v in + let i = 0 in + select0 v i === select0 w i + it "on one full zero basic block" $ + let v = DVS.fromList [0, 0, 0, 0, 0, 0, 0, 0] :: DVS.Vector Word64 in + let w = makePoppy512 v in + select0 v 0 === select0 w 0 + it "on one basic block" $ + forAll (vectorSizedBetween 1 8) $ \(ShowVector v) -> + forAll (choose (0, popCount0 v)) $ \i -> + let w = makePoppy512 v in + select0 v i === select0 w i + it "on two basic blocks" $ + forAll (vectorSizedBetween 9 16) $ \(ShowVector v) -> + forAll (choose (0, popCount0 v)) $ \i -> + let w = makePoppy512 v in + select0 v i === select0 w i + it "on three basic blocks" $ + forAll (vectorSizedBetween 17 24) $ \(ShowVector v) -> + forAll (choose (0, popCount0 v)) $ \i -> + let w = makePoppy512 v in + select0 v i === select0 w i + describe "select1 for Vector Word64 is equivalent to select1 for Poppy512" $ do + it "on empty bitvector" $ + let v = DVS.empty in + let w = makePoppy512 v in + let i = 0 in + select1 v i === select1 w i + it "on one full zero basic block" $ + let v = DVS.fromList [0, 0, 0, 0, 0, 0, 0, 0] :: DVS.Vector Word64 in + let w = makePoppy512 v in + select1 v 0 === select1 w 0 + it "on one basic block" $ + forAll (vectorSizedBetween 1 8) $ \(ShowVector v) -> + forAll (choose (0, popCount1 v)) $ \i -> + let w = makePoppy512 v in + select1 v i === select1 w i + it "on two basic blocks" $ + forAll (vectorSizedBetween 9 16) $ \(ShowVector v) -> + forAll (choose (0, popCount1 v)) $ \i -> + let w = makePoppy512 v in + select1 v i === select1 w i + it "on three basic blocks" $ + forAll (vectorSizedBetween 17 24) $ \(ShowVector v) -> + forAll (choose (0, popCount1 v)) $ \i -> + let w = makePoppy512 v in + select1 v i === select1 w i diff --git a/test/HaskellWorks/Data/Succinct/RankSelect/InternalSpec.hs b/test/HaskellWorks/Data/Succinct/RankSelect/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/RankSelect/InternalSpec.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.RankSelect.InternalSpec (spec) where + +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.PopCount.PopCount1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Internal +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Succinct.RankSelect.InternalSpec" $ do + describe "For [Bool]" $ do + it "rank True 10010010 over [0..8] should be 011122233" $ + let (Just bs) = bitRead "10010010" :: Maybe [Bool] in + fmap (rank True bs) [0..8] `shouldBe` [0, 1, 1, 1, 2, 2, 2, 3, 3] + it "rank True 10010010 over [0..8] should be 001223445" $ + let (Just bs) = bitRead "10010010" :: Maybe [Bool] in + fmap (rank False bs) [0..8] `shouldBe` [0, 0, 1, 2, 2, 3, 4, 4, 5] + it "select True 10010010 over [0..3] should be 0147" $ + let (Just bs) = bitRead "10010010" :: Maybe [Bool] in + fmap (select True bs) [0..3] `shouldBe` [0, 1, 4, 7] + it "select False 10010010 over [0..5] should be 023568" $ + let (Just bs) = bitRead "10010010" :: Maybe [Bool] in + fmap (select False bs) [0..5] `shouldBe` [0, 2, 3, 5, 6, 8] + it "Rank and select form a galois connection" $ + property $ \(bs :: [Bool]) -> + forAll (choose (0, popCount1 bs)) $ \(c :: Count) -> + rank True bs (select True bs c) == c diff --git a/test/HaskellWorks/Data/Succinct/SimpleSpec.hs b/test/HaskellWorks/Data/Succinct/SimpleSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Succinct/SimpleSpec.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Succinct.SimpleSpec (spec) where + +import Data.Vector +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.SuccinctSpec" $ do + it "rank1 for BitShown (Vector Word8) and BitShown (Vector Word64) should give same answer" $ + forAll (choose (0, 64)) $ \(i :: Count) (a :: Word8) (b :: Word8) (c :: Word8) (d :: Word8) + (e :: Word8) (f :: Word8) (g :: Word8) (h :: Word8) -> + let a64 = fromIntegral a :: Word64 in + let b64 = fromIntegral b :: Word64 in + let c64 = fromIntegral c :: Word64 in + let d64 = fromIntegral d :: Word64 in + let e64 = fromIntegral e :: Word64 in + let f64 = fromIntegral f :: Word64 in + let g64 = fromIntegral g :: Word64 in + let h64 = fromIntegral h :: Word64 in + let abcdefgh64 = (h64 .<. 56) .|. (g64 .<. 48) .|. (f64 .<. 40) .|. (e64 .<. 32) .|. + (d64 .<. 24) .|. (c64 .<. 16) .|. (b64 .<. 8 ) .|. a64 in + let vec16 = BitShown (fromList [a, b, c, d, e, f, g, h] :: Vector Word8 ) in + let vec64 = BitShown (fromList [abcdefgh64] :: Vector Word64) in + rank1 vec16 i == rank1 vec64 i + it "rank1 for BitShown (Vector Word16) and BitShown (Vector Word64) should give same answer" $ + forAll (choose (0, 64)) $ \(i :: Count) (a :: Word16) (b :: Word16) (c :: Word16) (d :: Word16) -> + let a64 = fromIntegral a :: Word64 in + let b64 = fromIntegral b :: Word64 in + let c64 = fromIntegral c :: Word64 in + let d64 = fromIntegral d :: Word64 in + let abcd64 = (d64 .<. 48) .|. (c64 .<. 32) .|. (b64 .<. 16) .|. a64 in + let vec16 = BitShown (fromList [a, b, c, d] :: Vector Word16) in + let vec64 = BitShown (fromList [abcd64] :: Vector Word64) in + rank1 vec16 i == rank1 vec64 i + it "rank1 for BitShown (Vector Word32) and BitShown (Vector Word64) should give same answer" $ + forAll (choose (0, 64)) $ \(i :: Count) (a :: Word32) (b :: Word32) -> + let a64 = fromIntegral a :: Word64 in + let b64 = fromIntegral b :: Word64 in + let ab64 = (b64 .<. 32) .|. a64 in + let vec32 = BitShown (fromList [a, b] :: Vector Word32) in + let vec64 = BitShown (fromList [ab64] :: Vector Word64) in + rank1 vec32 i == rank1 vec64 i diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}