array-builder 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+171/−22 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• array-builder.cabal +9/−3
• src-post-8.9/Compat.hs +38/−0
• src-pre-8.9/Compat.hs +33/−0
• src/Data/Builder.hs +52/−9
• src/Data/Builder/ST.hs +19/−6
• test/Main.hs +14/−3

@@ -1,5 +1,10 @@ # Revision history for array-builder +## 0.1.1.0 -- 2020-11-18++* Add `new1`.+* Add `Data.Builder.(doubleton|tripleton)`.+ ## 0.1.0.0 -- 2019-09-12 -* First version. Released on an unsuspecting world.+* First version.

@@ -1,6 +1,6 @@ cabal-version: 2.2 name: array-builder-version: 0.1.0.0+version: 0.1.1.0 synopsis: Builders for arrays homepage: https://github.com/andrewthad/array-builder bug-reports: https://github.com/andrewthad/array-builder/issues@@ -16,12 +16,18 @@   exposed-modules:     Data.Builder     Data.Builder.ST+  other-modules:+    Compat   build-depends:+    , array-chunks >=0.1 && <0.2     , base >=4.12 && <5     , primitive >=0.6.4 && <0.8     , run-st >=0.1 && <0.2-    , array-chunks >=0.1 && <0.2   hs-source-dirs: src+  if impl(ghc >= 8.9)+    hs-source-dirs: src-post-8.9+  else+    hs-source-dirs: src-pre-8.9   default-language: Haskell2010   ghc-options: -Wall -O2 @@ -30,8 +36,8 @@   hs-source-dirs: test   main-is: Main.hs   build-depends:-    , base     , array-builder+    , base     , tasty     , tasty-hunit   ghc-options: -Wall -O2

@@ -0,0 +1,38 @@+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Compat+  ( unsafeShrinkAndFreeze+  , unsafeShrinkAndFreeze#+  ) where++import Data.Primitive (SmallArray(..),SmallMutableArray(..))+import GHC.Exts (SmallArray#,SmallMutableArray#,Int(I#))+import GHC.Exts (State#,Int#)+import GHC.ST (ST(ST))++import qualified GHC.Exts as Exts++-- Shrink the mutable array in place and then freeze it.+-- The argument must not be reused after being passed to+-- this function.+unsafeShrinkAndFreeze ::+     SmallMutableArray s a+  -> Int+  -> ST s (SmallArray a)+{-# inline unsafeShrinkAndFreeze #-}+unsafeShrinkAndFreeze (SmallMutableArray x) (I# n) = ST+  (\s0 -> case Exts.shrinkSmallMutableArray# x n s0 of+    s1 -> case Exts.unsafeFreezeSmallArray# x s1 of+      (# s2, r #) -> (# s2, SmallArray r #)+  )++unsafeShrinkAndFreeze# ::+     SmallMutableArray# s a+  -> Int#+  -> State# s+  -> (# State# s, SmallArray# a #)+{-# inline unsafeShrinkAndFreeze# #-}+unsafeShrinkAndFreeze# x n s0 =+  case Exts.shrinkSmallMutableArray# x n s0 of+    s1 -> Exts.unsafeFreezeSmallArray# x s1

@@ -0,0 +1,33 @@+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Compat+  ( unsafeShrinkAndFreeze+  , unsafeShrinkAndFreeze#+  ) where++import Control.Monad.ST (ST)+import Data.Primitive (SmallArray,SmallMutableArray)+import GHC.Exts (SmallArray#,SmallMutableArray#,Int#,State#)++import qualified Data.Primitive as PM+import qualified GHC.Exts as Exts++-- Shrink the mutable array in place and then freeze it.+-- The argument must not be reused after being passed to+-- this function.+unsafeShrinkAndFreeze ::+     SmallMutableArray s a+  -> Int+  -> ST s (SmallArray a)+{-# inline unsafeShrinkAndFreeze #-}+unsafeShrinkAndFreeze arr = PM.freezeSmallArray arr 0++unsafeShrinkAndFreeze# ::+     SmallMutableArray# s a+  -> Int#+  -> State# s+  -> (# State# s, SmallArray# a #)+{-# inline unsafeShrinkAndFreeze# #-}+unsafeShrinkAndFreeze# x n s0 =+  Exts.freezeSmallArray# x 0# n s0

@@ -8,22 +8,22 @@     Builder(..)   , cons   , singleton+  , doubleton+  , tripleton     -- * Run   , run   ) where +import Compat (unsafeShrinkAndFreeze#)+import Data.Chunks (Chunks(ChunksNil,ChunksCons)) import Data.Primitive (SmallArray(SmallArray))-import Control.Monad.ST.Run (runSmallArrayST)+import GHC.Exts ((*#),(+#),(-#),(>#))+import GHC.Exts (SmallMutableArray#) import GHC.Exts (State#,Int#,runRW#)+import GHC.Exts (newSmallArray#) import GHC.Exts (writeSmallArray#,unsafeFreezeSmallArray#)-import GHC.Exts (SmallMutableArray#,freezeSmallArray#)-import GHC.Exts (newSmallArray#,sizeofSmallArray#)-import GHC.Exts ((*#),(+#),(-#),(>#))-import Data.Chunks (Chunks(ChunksNil,ChunksCons))  import qualified Data.Chunks as C-import qualified Data.Foldable as F-import qualified Data.Primitive as PM  -- | Builder for an array of boxed elements. newtype Builder a = Builder@@ -45,7 +45,7 @@         -- Recall that freezeSmallArray copies a slice.         -- If resize functions ever become available for         -- SmallArray, we should use that instead.-        case freezeSmallArray# marr 0# off s2 of+        case unsafeShrinkAndFreeze# marr off s2 of           (# s3, arr #) ->             let !r = C.reverseOnto                   (ChunksCons (SmallArray arr) ChunksNil)@@ -76,6 +76,7 @@ {-# inline cons #-} cons a b = singleton a <> b +-- | A builder with one element. singleton :: a -> Builder a {-# noinline singleton #-} singleton a = Builder@@ -83,13 +84,55 @@     1# -> case writeSmallArray# marr off a s0 of       s1 -> (# s1, marr, off +# 1#, len -# 1#, cs #)     _ -> case unsafeFreezeSmallArray# marr s0 of-      (# s1, arr #) -> let !lenNew = nextLength (sizeofSmallArray# arr) in+      (# s1, arr #) -> let !lenNew = nextLength off in         -- Since we feed the element to newSmallArray#, we do not         -- need to write it to the 0 index.         case newSmallArray# lenNew a s1 of           (# s2, marrNew #) ->             let !csNew = ChunksCons (SmallArray arr) cs in               (# s2, marrNew, 1#, lenNew -# 1#, csNew #)+  )++-- | A builder with two elements.+--+-- @since 0.1.1.0+doubleton :: a -> a -> Builder a+{-# noinline doubleton #-}+doubleton a b = Builder+  (\marr off len cs s0 -> case len ># 1# of+    1# -> case writeSmallArray# marr off a s0 of+      s1 -> case writeSmallArray# marr (off +# 1#) b s1 of+        s2 -> (# s2, marr, off +# 2#, len -# 2#, cs #)+    _ -> case unsafeShrinkAndFreeze# marr off s0 of+      (# s1, arr #) -> let !lenNew = nextLength off in+        -- Since we feed the element to newSmallArray#, we do not+        -- need to write element a to the 0 index.+        case newSmallArray# lenNew a s1 of+          (# s2, marrNew #) -> case writeSmallArray# marrNew 1# b s2 of+            s3 -> let !csNew = ChunksCons (SmallArray arr) cs in+              (# s3, marrNew, 2#, lenNew -# 2#, csNew #)+  )++-- | A builder with three elements.+--+-- @since 0.1.1.0+tripleton :: a -> a -> a -> Builder a+{-# noinline tripleton #-}+tripleton a b c = Builder+  (\marr off len cs s0 -> case len ># 1# of+    1# -> case writeSmallArray# marr off a s0 of+      s1 -> case writeSmallArray# marr (off +# 1#) b s1 of+        s2 -> case writeSmallArray# marr (off +# 2#) c s2 of+          s3 -> (# s3, marr, off +# 3#, len -# 3#, cs #)+    _ -> case unsafeShrinkAndFreeze# marr off s0 of+      (# s1, arr #) -> let !lenNew = nextLength off in+        -- Since we feed the element to newSmallArray#, we do not+        -- need to write element a to the 0 index.+        case newSmallArray# lenNew a s1 of+          (# s2, marrNew #) -> case writeSmallArray# marrNew 1# b s2 of+            s3 -> case writeSmallArray# marrNew 2# c s3 of+              s4 -> let !csNew = ChunksCons (SmallArray arr) cs in+                (# s4, marrNew, 3#, lenNew -# 3#, csNew #)   )  nextLength :: Int# -> Int#

@@ -3,15 +3,17 @@ module Data.Builder.ST   ( Builder(..)   , new+  , new1   , push   , freeze    ) where -import Data.Primitive (SmallMutableArray)+import Compat (unsafeShrinkAndFreeze) import Control.Monad.ST (ST)-import Data.Primitive (newSmallArray,writeSmallArray,unsafeFreezeSmallArray)-import Data.Primitive (sizeofSmallArray,freezeSmallArray) import Data.Chunks (Chunks(ChunksNil,ChunksCons))+import Data.Primitive (SmallMutableArray)+import Data.Primitive (newSmallArray,writeSmallArray,unsafeFreezeSmallArray)+import Data.Primitive (sizeofSmallArray) import Foreign.Storable (sizeOf)  import qualified Data.Chunks as C@@ -35,6 +37,17 @@   marr <- newSmallArray initialLength errorThunk   pure (Builder marr 0 initialLength ChunksNil) +-- | Create a new 'Builder' with a single element. Useful when builder+-- creation is immidiately followed by 'push'. Note that:+--+-- > new >>= push x ≡ new1 x+--+-- But 'new1' performs slightly better.+new1 :: a -> ST s (Builder s a)+new1 a0 = do+  marr <- newSmallArray initialLength a0+  pure (Builder marr 1 initialLength ChunksNil)+ -- | Push an element onto the end of the builder. This -- is not strict in the element, so force it before pushing -- it on to the builder if doing so is needed to prevent@@ -55,8 +68,8 @@     pure $! Builder marrNew 1 (lenNew - 1) csNew  -- The sequence of sizes we create is:---   64-bit: 14, 30, 62, 126, 254, 254, 254...---   32-bit: 14, 30, 62, 126, 254, 510, 510, 510...+--   64-bit: 6, 14, 30, 62, 126, 254, 254, 254...+--   32-bit: 6, 14, 30, 62, 126, 254, 510, 510, 510... -- The goal is to have objects whose sizes are increasing -- powers of 2 until we reach the size of a block (4KB). -- A 254-element SmallArray on a 64-bit platform uses@@ -81,7 +94,7 @@      Builder s a -- ^ Builder, do not reuse after freezing   -> ST s (Chunks a) freeze (Builder marr off _ cs) = do-  arr <- freezeSmallArray marr 0 off+  arr <- unsafeShrinkAndFreeze marr off   pure $! C.reverseOnto (ChunksCons arr ChunksNil) cs  errorThunk :: a

@@ -2,14 +2,12 @@ {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} -import Data.Builder (singleton,run)-import Control.Monad.ST (runST)+import Data.Builder (singleton,doubleton,tripleton,run) import Test.Tasty (defaultMain,testGroup,TestTree) import Test.Tasty.HUnit ((@=?)) import Data.Semigroup (stimes) import qualified Data.List as L import qualified Data.Foldable as F-import qualified GHC.Exts as Exts import qualified Test.Tasty.HUnit as THU  main :: IO ()@@ -37,4 +35,17 @@     )   , THU.testCase "C" $ (L.replicate 500 'X') @=?     (F.toList $ run (stimes (500 :: Int) (singleton 'X')))+  , THU.testCase "D" $ "ACDCDCDCDCDCDCDCDCDX" @=?+    ( F.toList $ run+      (  singleton 'A'+      <> stimes (9 :: Int) (doubleton 'C' 'D')+      <> singleton 'X'+      )+    )+  , THU.testCase "E" $ "ABCABCABCABCABCABCABCX" @=?+    ( F.toList $ run+      (  stimes (7 :: Int) (tripleton 'A' 'B' 'C')+      <> singleton 'X'+      )+    )   ]