diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for array-chunks + +## 0.1.0.0 -- 2019-08-12 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/array-chunks.cabal b/array-chunks.cabal new file mode 100644 --- /dev/null +++ b/array-chunks.cabal @@ -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 diff --git a/src/Data/Chunks.hs b/src/Data/Chunks.hs new file mode 100644 --- /dev/null +++ b/src/Data/Chunks.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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)