array-chunks (empty) → 0.1.0.0

raw patch · 6 files changed

+275/−0 lines, 6 filesdep +QuickCheckdep +array-chunksdep +basesetup-changed

Dependencies added: QuickCheck, array-chunks, base, primitive, quickcheck-classes, tasty, tasty-hunit, tasty-quickcheck

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
array-chunks.cabal +42/−0
src/Data/Chunks.hs +138/−0
test/Main.hs +58/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for array-chunks++## 0.1.0.0 -- 2019-08-12++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ array-chunks.cabal view

@@ -0,0 +1,42 @@+cabal-version:       2.2+name: array-chunks+version: 0.1.0.0+synopsis: Lists of chunks+description:+  Lists of chunks. This is similar to the Cons List provided+  by `Data.List`, but it is more useful as a target for a+  builder since the chunks are cache coherent.+homepage: https://github.com/andrewthad/array-chunks+bug-reports: https://github.com/andrewthad/array-chunks/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2019 Andrew Martin+category: Data+extra-source-files: CHANGELOG.md++library+  exposed-modules: Data.Chunks+  build-depends:+    , base >=4.12 && <5+    , primitive >=0.6.4 && <0.8+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -O2 -Wall++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    , QuickCheck+    , array-chunks+    , base+    , primitive+    , quickcheck-classes >=0.6.3 && <0.7+    , tasty+    , tasty-hunit+    , tasty-quickcheck+  ghc-options: -Wall -O2+  default-language: Haskell2010

+ src/Data/Chunks.hs view

@@ -0,0 +1,138 @@+{-# language BangPatterns #-}+{-# language DerivingStrategies #-}+{-# language TypeFamilies #-}++module Data.Chunks+  ( Chunks(..)+  , reverse+  , reverseOnto+  ) where++import Prelude hiding (reverse)++import Data.Primitive (SmallArray)+import GHC.Exts (IsList)++import qualified GHC.Exts as Exts+import qualified Data.Foldable as F+import qualified Data.Primitive as PM++-- | A list of chunks. This is a foundation on top of+-- which efficient builder-like abstractions can be+-- implemented. There are no restrictions on the number+-- of elements in each chunk, although extremely small+-- chunks (singleton or doubleton chunks) may lead to+-- poor performance.+data Chunks a+  = ChunksCons !(SmallArray a) !(Chunks a)+  | ChunksNil+  deriving stock (Show)++instance Eq a => Eq (Chunks a) where+  (==) = eqChunks++instance IsList (Chunks a) where+  type Item (Chunks a) = SmallArray a+  toList = chunksToSmallArrayList+  fromList xs = F.foldr ChunksCons ChunksNil xs++chunksToSmallArrayList :: Chunks a -> [SmallArray a]+chunksToSmallArrayList ChunksNil = []+chunksToSmallArrayList (ChunksCons x xs) =+  x : chunksToSmallArrayList xs++eqChunks :: Eq a => Chunks a -> Chunks a -> Bool+eqChunks ChunksNil cs = allEmpty cs+eqChunks (ChunksCons x xs) cs = eqChunksConsLeft x 0 (PM.sizeofSmallArray x) xs cs++-- The first argument chunk belongs to the second argument chunks.+-- It is its head. +eqChunksConsLeft :: Eq a => SmallArray a -> Int -> Int -> Chunks a -> Chunks a -> Bool+eqChunksConsLeft !_ !_ !len xs ChunksNil = case len of+  0 -> allEmpty xs+  _ -> False+eqChunksConsLeft x !off !len xs (ChunksCons y ys) =+  eqChunksConsBoth x off len y 0 (PM.sizeofSmallArray y) xs ys++eqChunksConsRight :: Eq a => Chunks a -> SmallArray a -> Int -> Int -> Chunks a -> Bool+eqChunksConsRight ChunksNil !_ !_ !len ys = case len of+  0 -> allEmpty ys+  _ -> False+eqChunksConsRight (ChunksCons x xs) !y !off !len ys =+  eqChunksConsBoth x 0 (PM.sizeofSmallArray x) y off len xs ys++eqChunksConsBoth :: Eq a => SmallArray a -> Int -> Int -> SmallArray a -> Int -> Int -> Chunks a -> Chunks a -> Bool+eqChunksConsBoth !xh !xoff !xlen !yh !yoff !ylen !xt !yt = case compare xlen ylen of+  LT -> eqRange xh xoff yh yoff xlen && eqChunksConsRight xt yh xlen (ylen - xlen) yt+  GT -> eqRange xh xoff yh yoff ylen && eqChunksConsLeft xh ylen (xlen - ylen) xt yt+  EQ -> xh == yh && eqChunks xt yt++eqRange :: Eq a => SmallArray a -> Int -> SmallArray a -> Int -> Int -> Bool+eqRange !xs !xoff !ys !yoff !len+  | len == 0 = True+  | otherwise =+      PM.indexSmallArray xs xoff == PM.indexSmallArray ys yoff &&+      eqRange xs (xoff + 1) ys (yoff + 1) (len - 1)++allEmpty :: Chunks a -> Bool+allEmpty ChunksNil = True+allEmpty (ChunksCons x xs) = case PM.sizeofSmallArray x of+  0 -> allEmpty xs+  _ -> False++instance Semigroup (Chunks a) where+  ChunksNil <> a = a+  cs@(ChunksCons _ _) <> ChunksNil = cs+  as@(ChunksCons _ _) <> bs@(ChunksCons _ _) =+    reverseOnto bs (reverse as)++instance Monoid (Chunks a) where+  mempty = ChunksNil++instance Foldable Chunks where+  {-# inline foldl' #-}+  {-# inline foldr #-}+  {-# inline length #-}+  foldl' = chunksFoldl'+  foldr = chunksFoldr+  length = chunksLength++chunksFoldl' :: (b -> a -> b) -> b -> Chunks a -> b+{-# inline chunksFoldl' #-}+chunksFoldl' f = go where+  go !acc ChunksNil = acc+  go !acc (ChunksCons x cs) = go (F.foldl' f acc x) cs++chunksFoldr :: (a -> b -> b) -> b -> Chunks a -> b+{-# inline chunksFoldr #-}+chunksFoldr f z0 = go where+  go ChunksNil = z0+  go (ChunksCons x cs) = F.foldr f (go cs) x++chunksLength :: Chunks a -> Int+{-# inline chunksLength #-}+chunksLength = chunksLengthGo 0++chunksLengthGo :: Int -> Chunks a -> Int+chunksLengthGo !n ChunksNil = n+chunksLengthGo !n (ChunksCons c cs) =+  chunksLengthGo (n + PM.sizeofSmallArray c) cs++-- | Reverse chunks but not the elements within each+-- chunk.+--+-- >>> reverse [[42,17,94],[6,12],[3,14]]+-- [[3,14],[6,12],[42,17,94]]+reverse :: Chunks a -> Chunks a+reverse = reverseOnto ChunksNil++-- | Variant of 'reverse' that allows the caller to provide+-- an initial list of chunks that the reversed chunks will+-- be pushed onto.+--+-- >>> reverseOnto [[15],[12,4]] [[42,17,94],[6,12],[3,14]]+-- [[3,14],[6,12],[42,17,94],[15],[12,4]]+reverseOnto :: Chunks a -> Chunks a -> Chunks a+reverseOnto !x ChunksNil = x+reverseOnto !x (ChunksCons y ys) =+  reverseOnto (ChunksCons y x) ys

+ test/Main.hs view

@@ -0,0 +1,58 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++import Data.Chunks (Chunks(ChunksCons,ChunksNil))+import Data.Primitive (SmallArray)+import Data.Proxy (Proxy(Proxy))+import Test.QuickCheck (Arbitrary,Gen)+import Test.QuickCheck.Classes (eqLaws,semigroupLaws)+import Test.QuickCheck.Classes (monoidLaws,isListLaws,foldableLaws)+import Test.Tasty (defaultMain,testGroup,TestTree)+import qualified GHC.Exts as Exts+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Classes as QCC+import qualified Test.Tasty.QuickCheck as TQC++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Chunks"+  [ lawsToTest (eqLaws (Proxy :: Proxy (Chunks Integer)))+  , lawsToTest (semigroupLaws (Proxy :: Proxy (Chunks Integer)))+  , lawsToTest (monoidLaws (Proxy :: Proxy (Chunks Integer)))+  , lawsToTest (isListLaws (Proxy :: Proxy (Chunks Integer)))+  , lawsToTest (foldableLaws (Proxy :: Proxy Chunks))+  ]++lawsToTest :: QCC.Laws -> TestTree+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)++instance Arbitrary a => Arbitrary (Chunks a) where+  arbitrary = QC.choose (0,3 :: Int) >>= \case+    0 -> pure ChunksNil+    1 -> do+      a <- arbitrarySmallArray+      pure (ChunksCons a ChunksNil)+    2 -> do+      a <- arbitrarySmallArray+      b <- arbitrarySmallArray+      pure (ChunksCons a (ChunksCons b ChunksNil))+    3 -> do+      a <- arbitrarySmallArray+      b <- arbitrarySmallArray+      c <- arbitrarySmallArray+      pure (ChunksCons a (ChunksCons b (ChunksCons c ChunksNil)))+    _ -> error "Chunks.arbitrary: not possible"++instance Arbitrary a => Arbitrary (SmallArray a) where+  arbitrary = arbitrarySmallArray++arbitrarySmallArray :: Arbitrary a => Gen (SmallArray a)+arbitrarySmallArray = do+  n <- QC.choose (0,2 :: Int)+  fmap Exts.fromList (QC.vectorOf n QC.arbitrary)