Z-Data 0.9.0.0 → 1.0.0.0

raw patch · 49 files changed

+2363/−1839 lines, 49 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−1
• Z-Data.cabal +17/−6
• Z/Data/Array.hs +502/−688
• Z/Data/Array/Base.hs +692/−0
• Z/Data/Array/Cast.hs +18/−0
• Z/Data/Array/Checked.hs +0/−328
• Z/Data/Array/QQ.hs +8/−2
• Z/Data/Array/Unaligned.hs +0/−1
• Z/Data/Array/UnliftedArray.hs +40/−40
• Z/Data/Builder.hs +8/−0
• Z/Data/Builder/Base.hs +78/−49
• Z/Data/Builder/Numeric.hs +29/−8
• Z/Data/Builder/Numeric/DigitTable.hs +3/−0
• Z/Data/Builder/Time.hs +59/−16
• Z/Data/CBytes.hs +12/−13
• Z/Data/JSON.hs +1/−1
• Z/Data/JSON/Base.hs +3/−2
• Z/Data/JSON/Builder.hs +10/−9
• Z/Data/JSON/Converter.hs +1/−0
• Z/Data/JSON/Value.hs +9/−9
• Z/Data/Parser.hs +2/−2
• Z/Data/Parser/Base.hs +145/−127
• Z/Data/Parser/Numeric.hs +102/−24
• Z/Data/Parser/Time.hs +57/−5
• Z/Data/PrimRef.hs +228/−17
• Z/Data/PrimRef/PrimIORef.hs +0/−193
• Z/Data/PrimRef/PrimSTRef.hs +0/−60
• Z/Data/Text.hs +1/−1
• Z/Data/Text/Base.hs +21/−13
• Z/Data/Text/Extra.hs +37/−37
• Z/Data/Text/Print.hs +5/−5
• Z/Data/Text/Search.hs +12/−12
• Z/Data/Vector.hs +2/−1
• Z/Data/Vector/Base.hs +94/−39
• Z/Data/Vector/Base64.hs +3/−3
• Z/Data/Vector/Extra.hs +48/−38
• Z/Data/Vector/FlatIntMap.hs +11/−11
• Z/Data/Vector/FlatIntSet.hs +10/−10
• Z/Data/Vector/FlatMap.hs +11/−11
• Z/Data/Vector/FlatSet.hs +10/−10
• Z/Data/Vector/Hex.hs +4/−4
• Z/Data/Vector/Search.hs +12/−12
• Z/Data/Vector/Sort.hs +8/−8
• Z/Foreign.hs +20/−14
• Z/Foreign/CPtr.hs +1/−1
• test/Z/Data/Builder/TimeSpec.hs +4/−3
• test/Z/Data/Parser/BaseSpec.hs +2/−2
• test/Z/Data/Parser/TimeSpec.hs +5/−3
• test/Z/Data/Vector/BaseSpec.hs +8/−0

@@ -1,8 +1,17 @@ # Revision history for Z-Data +## 1.0.0.0  -- 2021-07-05++* Clean up various `RULES` and `INLINE` pragmas, improve building time a little.+* Simplify `Z.Data.PrimRef` to use `PrimMonad`.+* Add `encodeXXX/encodeXXXLE/encodeXXXBE`(where `XXX` is a primitive type) to `Z.Data.Builder`.+* Add `check-array-bound` build flag to enable bound check in `Z.Data.Array` module, `Z.Data.Array.Checked` is removed.+* Add `concatR` to `Z.Data.Vector` and `Z.Data.Text`, which is useful to concat the result of an accumulator style recursive function.+* Improve date builder and parser by introducing faster common case path.  + ## 0.9.0.0  -- 2021-07-01 -* Add `decodeXXX/deocodeXXXLE/deodeXXXBE`(where `XXX` is a primitive type) to `Z.Data.Parser`.+* Add `decodeXXX/deocodeXXXLE/decodeXXXBE`(where `XXX` is a primitive type) to `Z.Data.Parser`. * Rename `replicateMVec/traveseVec/traveseVec_` tp `replicateM/travese/travese_`, fix related `PrimMonad` rules not firing issue. * Add a faster `sciToDouble` based on https://github.com/lemire/fast_double_parser, improve `double/double'` parser. 

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               Z-Data-version:            0.9.0.0+version:            1.0.0.0 synopsis:           Array, vector and text description:        This package provides array, slice and text operations license:            BSD-3-Clause@@ -105,6 +105,13 @@   type:     git   location: git://github.com/haskell-Z/z-data.git +flag check-array-bound+  description:+    Add bound check to operations in Z.Data.Array module.++  default:     False+  manual:      True+ flag integer-simple   description:     Use the [simple integer library](http://hackage.haskell.org/package/integer-simple)@@ -131,8 +138,8 @@ library   exposed-modules:     Z.Data.Array+    Z.Data.Array.Base     Z.Data.Array.Cast-    Z.Data.Array.Checked     Z.Data.Array.QQ     Z.Data.Array.Unaligned     Z.Data.Array.UnliftedArray@@ -154,8 +161,6 @@     Z.Data.Parser.Numeric     Z.Data.Parser.Time     Z.Data.PrimRef-    Z.Data.PrimRef.PrimIORef-    Z.Data.PrimRef.PrimSTRef     Z.Data.Text     Z.Data.Text.Base     Z.Data.Text.Extra@@ -278,6 +283,8 @@   build-tool-depends: hsc2hs:hsc2hs -any    cc-options:         -std=c11 -Wall -Wno-pointer-to-int-cast -Wno-unused-function+  -- currently it's ignored, see https://github.com/haskell/cabal/pull/6226+  -- we work around this issue using Setup.hs   cxx-options:        -std=c++11   if os(osx)     cxx-options:        -stdlib=libc++@@ -315,9 +322,10 @@   else     cpp-options:   -DINTEGER_GMP     build-depends: integer-gmp >=0.2 && <1.2-  -- currently it's ignored, see https://github.com/haskell/cabal/pull/6226-  -- we work around this issue using Setup.hs +  if flag(check-array-bound)+    cpp-options:   -DCHECK_ARRAY_BOUND+   ghc-options:     -Wall -Wno-unticked-promoted-constructors  -Wno-incomplete-patterns @@ -414,3 +422,6 @@   else     cpp-options:   -DINTEGER_GMP     build-depends: integer-gmp >=0.2 && <1.2++  if flag(check-array-bound)+    cpp-options:   -DCHECK_ARRAY_BOUND

@@ -1,689 +1,503 @@ {-|-Module      : Z.Data.Array-Description : Fast boxed and unboxed arrays-Copyright   : (c) Dong Han, 2017-License     : BSD-Maintainer  : winterland1989@gmail.com-Stability   : experimental-Portability : non-portable--Unified unboxed and boxed array operations using type family.--NONE of the operations are bound checked, if you need checked operations please use "Z.Data.Array.Checked" instead.-It exports the exact same APIs ,so it requires no extra effort to switch between them.--Some mnemonics:--  * 'newArr' and 'newArrWith' return mutable array.-    'readArr' and 'writeArr' perform read and write actions on mutable arrays.-    'setArr' fills the elements with offset and length.--  * 'indexArr' can only work on immutable Array.-     Use 'indexArr'' to avoid thunks building up in the heap.--  * The order of arguements of 'copyArr', 'copyMutableArr' and 'moveArr' are always target and its offset-    come first, and source and source offset follow, copying length comes last.--}--module Z.Data.Array (-  -- * Arr typeclass-    Arr(..)-  , emptyArr, singletonArr, doubletonArr-  , modifyIndexArr, insertIndexArr, deleteIndexArr-  , RealWorld-  -- * Boxed array type-  , Array(..)-  , MutableArray(..)-  , SmallArray(..)-  , SmallMutableArray(..)-  , uninitialized-  -- * Primitive array type-  , PrimArray(..)-  , MutablePrimArray(..)-  , Prim(..)-  -- * Primitive array operations-  , newPinnedPrimArray, newAlignedPinnedPrimArray-  , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray-  , primArrayContents, mutablePrimArrayContents, withPrimArrayContents, withMutablePrimArrayContents-  , isPrimArrayPinned, isMutablePrimArrayPinned-  -- * Unlifted array type-  , UnliftedArray(..)-  , MutableUnliftedArray(..)-  , PrimUnlifted(..)-  -- * The 'ArrayException' type-  , ArrayException(..)-  -- * Cast between primitive arrays-  , Cast-  , castArray-  , castMutableArray-  -- * Re-export-  , sizeOf-  ) where--import           Control.Exception              (ArrayException (..), throw)-import           Control.Monad-import           Control.Monad.Primitive-import           Control.Monad.ST-import           Data.Kind                      (Type)-import           Data.Primitive.Array-import           Data.Primitive.ByteArray-import           Data.Primitive.PrimArray-import           Data.Primitive.Ptr             (copyPtrToMutablePrimArray)-import           Data.Primitive.SmallArray-import           Data.Primitive.Types-import           GHC.Exts-import           Z.Data.Array.Cast-import           Z.Data.Array.UnliftedArray----- | Bottom value (@throw ('UndefinedElement' 'Data.Array.uninitialized')@)--- for new boxed array('Array', 'SmallArray'..) initialization.----uninitialized :: a-uninitialized = throw (UndefinedElement "Data.Array.uninitialized")----- | The typeclass that unifies box & unboxed and mutable & immutable array operations.------ Most of these functions simply wrap their primitive counterpart.--- When there are no primitive ones, we fulfilled the semantic with other operations.------ One exception is 'shrinkMutableArr' which only performs closure resizing on 'PrimArray', because--- currently, RTS only supports that. 'shrinkMutableArr' won't do anything on other array types.------ It's reasonable to trust GHC to specialize & inline these polymorphic functions.--- They are used across this package and perform identically to their monomorphic counterpart.----class Arr (arr :: Type -> Type) a where---    -- | The mutable version of this array type.-    ---    type MArr arr = (mar :: Type -> Type -> Type) | mar -> arr---    -- | Make a new array with a given size.-    ---    -- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed.-    -- For primitive arrays, elements are just random garbage.-    newArr :: (PrimMonad m, PrimState m ~ s) => Int -> m (MArr arr s a)---    -- | Make a new array and fill it with an initial value.-    newArrWith :: (PrimMonad m, PrimState m ~ s) => Int -> a -> m (MArr arr s a)---    -- | Read from specified index of mutable array in a primitive monad.-    readArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m a---    -- | Write to specified index of mutable array in a primitive monad.-    writeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> a -> m ()---    -- | Fill the mutable array with a given value.-    setArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> a -> m ()---    -- | Read from the specified index of an immutable array. It's pure and often-    -- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this.-    indexArr :: arr a -> Int -> a---    -- | Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated.-    -- Pattern matching on the tuple forces the indexing of the array to happen but does not evaluate the element itself.-    -- Evaluating the thunk prevents additional thunks from building up on the heap.-    -- Avoiding these thunks, in turn, reduces references to the argument array, allowing it to be garbage collected more promptly.-    indexArr' :: arr a -> Int -> (# a #)---    -- | Monadically read a value from the immutable array at the given index.-    -- This allows us to be strict in the array while remaining lazy in the read-    -- element which is very useful for collective operations. Suppose we want to-    -- copy an array. We could do something like this:-    ---    -- > copy marr arr ... = do ...-    -- >                        writeArray marr i (indexArray arr i) ...-    -- >                        ...-    ---    -- But since primitive arrays are lazy, the calls to 'indexArray' will not be-    -- evaluated. Rather, @marr@ will be filled with thunks each of which would-    -- retain a reference to @arr@. This is definitely not what we want!-    ---    -- With 'indexArrayM', we can instead write-    ---    -- > copy marr arr ... = do ...-    -- >                        x <- indexArrayM arr i-    -- >                        writeArray marr i x-    -- >                        ...-    ---    -- Now, indexing is executed immediately although the returned element is-    -- still not evaluated.-    ---    -- /Note:/ this function does not do bounds checking.-    indexArrM :: (Monad m) => arr a -> Int -> m a---    -- | Create an immutable copy of a slice of an array.-    -- This operation makes a copy of the specified section, so it is safe to continue using the mutable array afterward.-    freezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (arr a)---    -- | Create a mutable array from a slice of an immutable array.-    -- This operation makes a copy of the specified slice, so it is safe to use the immutable array afterward.-    thawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> Int -> Int -> m (MArr arr s a)---    -- | Convert a mutable array to an immutable one without copying.-    -- The array should not be modified after the conversion.-    unsafeFreezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m (arr a)----    -- | Convert a mutable array to an immutable one without copying. The-    -- array should not be modified after the conversion.-    unsafeThawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> m (MArr arr s a)---    -- | Copy a slice of an immutable array to a mutable array at given offset.-    copyArr ::  (PrimMonad m, PrimState m ~ s)-            => MArr arr s a -- ^ target-            -> Int          -- ^ offset into target array-            -> arr a        -- ^ source-            -> Int          -- ^ offset into source array-            -> Int          -- ^ number of elements to copy-            -> m ()---    -- | Copy a slice of a mutable array to another mutable array at given offset.-    -- The two mutable arrays must not be the same.-    copyMutableArr :: (PrimMonad m, PrimState m ~ s)-                   => MArr arr s a  -- ^ target-                   -> Int           -- ^ offset into target array-                   -> MArr arr s a  -- ^ source-                   -> Int           -- ^ offset into source array-                   -> Int           -- ^ number of elements to copy-                   -> m ()---    -- | Copy a slice of a mutable array to a mutable array at given offset.-    -- The two mutable arrays can be the same.-    moveArr :: (PrimMonad m, PrimState m ~ s)-            => MArr arr s a  -- ^ target-            -> Int           -- ^ offset into target array-            -> MArr arr s a  -- ^ source-            -> Int           -- ^ offset into source array-            -> Int           -- ^ number of elements to copy-            -> m ()---    -- | Create an immutable copy with the given subrange of the original array.-    cloneArr :: arr a -> Int -> Int -> arr a---    -- | Create a mutable copy the given subrange of the original array.-    cloneMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (MArr arr s a)---    -- | Resize a mutable array to the given size.-    resizeMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m (MArr arr s a)---    -- | Shrink a mutable array to the given size. This operation only works on primitive arrays.-    -- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change.-    shrinkMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m ()---    -- | Is two mutable array are reference equal.-    sameMutableArr :: MArr arr s a -> MArr arr s a -> Bool---    -- | Size of the immutable array.-    sizeofArr :: arr a -> Int---    -- | Size of the mutable array.-    sizeofMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m Int---    -- | Check whether the two immutable arrays refer to the same memory block-    ---    -- Note that the result of 'sameArr' may change depending on compiler's optimizations, for example,-    -- @let arr = runST ... in arr `sameArr` arr@ may return false if compiler decides to-    -- inline it.-    ---    -- See https://ghc.haskell.org/trac/ghc/ticket/13908 for more context.-    ---    sameArr :: arr a -> arr a -> Bool--instance Arr Array a where-    type MArr Array = MutableArray-    newArr n = newArray n uninitialized-    {-# INLINE newArr #-}-    newArrWith = newArray-    {-# INLINE newArrWith #-}-    readArr = readArray-    {-# INLINE readArr #-}-    writeArr = writeArray-    {-# INLINE writeArr #-}-    setArr marr s l x = go s-      where-        !sl = s + l-        go !i | i >= sl = return ()-              | otherwise = writeArray marr i x >> go (i+1)-    {-# INLINE setArr #-}-    indexArr = indexArray-    {-# INLINE indexArr #-}-    indexArr' (Array arr#) (I# i#) = indexArray# arr# i#-    {-# INLINE indexArr' #-}-    indexArrM = indexArrayM-    {-# INLINE indexArrM #-}-    freezeArr = freezeArray-    {-# INLINE freezeArr #-}-    thawArr = thawArray-    {-# INLINE thawArr #-}-    unsafeFreezeArr = unsafeFreezeArray-    {-# INLINE unsafeFreezeArr #-}-    unsafeThawArr = unsafeThawArray-    {-# INLINE unsafeThawArr #-}--    copyArr = copyArray-    {-# INLINE copyArr #-}-    copyMutableArr = copyMutableArray-    {-# INLINE copyMutableArr #-}--    moveArr marr1 s1 marr2 s2 l-        | l <= 0 = return ()-        | sameMutableArray marr1 marr2 =-            case compare s1 s2 of-                LT ->-                    let !d = s2 - s1-                        !s2l = s2 + l-                        go !i | i >= s2l = return ()-                              | otherwise = do x <- readArray marr2 i-                                               writeArray marr1 (i-d) x-                                               go (i+1)-                    in go s2--                EQ -> return ()--                GT ->-                    let !d = s1 - s2-                        go !i | i < s2 = return ()-                              | otherwise = do x <- readArray marr2 i-                                               writeArray marr1 (i+d) x-                                               go (i-1)-                    in go (s2+l-1)-        | otherwise = copyMutableArray marr1 s1 marr2 s2 l-    {-# INLINE moveArr #-}--    cloneArr = cloneArray-    {-# INLINE cloneArr #-}-    cloneMutableArr = cloneMutableArray-    {-# INLINE cloneMutableArr #-}--    resizeMutableArr marr n = do-        marr' <- newArray n uninitialized-        copyMutableArray marr' 0 marr 0 (sizeofMutableArray marr)-        return marr'-    {-# INLINE resizeMutableArr #-}-    shrinkMutableArr _ _ = return ()-    {-# INLINE shrinkMutableArr #-}--    sameMutableArr = sameMutableArray-    {-# INLINE sameMutableArr #-}-    sizeofArr = sizeofArray-    {-# INLINE sizeofArr #-}-    sizeofMutableArr = return . sizeofMutableArray-    {-# INLINE sizeofMutableArr #-}--    sameArr (Array arr1#) (Array arr2#) = isTrue# (-        sameMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#))-    {-# INLINE sameArr #-}--instance Arr SmallArray a where-    type MArr SmallArray = SmallMutableArray-    newArr n = newSmallArray n uninitialized-    {-# INLINE newArr #-}-    newArrWith = newSmallArray-    {-# INLINE newArrWith #-}-    readArr = readSmallArray-    {-# INLINE readArr #-}-    writeArr = writeSmallArray-    {-# INLINE writeArr #-}-    setArr marr s l x = go s-      where-        !sl = s + l-        go !i | i >= sl = return ()-              | otherwise = writeSmallArray marr i x >> go (i+1)-    {-# INLINE setArr #-}-    indexArr = indexSmallArray-    {-# INLINE indexArr #-}-    indexArr' (SmallArray arr#) (I# i#) = indexSmallArray# arr# i#-    {-# INLINE indexArr' #-}-    indexArrM = indexSmallArrayM-    {-# INLINE indexArrM #-}-    freezeArr = freezeSmallArray-    {-# INLINE freezeArr #-}-    thawArr = thawSmallArray-    {-# INLINE thawArr #-}-    unsafeFreezeArr = unsafeFreezeSmallArray-    {-# INLINE unsafeFreezeArr #-}-    unsafeThawArr = unsafeThawSmallArray-    {-# INLINE unsafeThawArr #-}--    copyArr = copySmallArray-    {-# INLINE copyArr #-}-    copyMutableArr = copySmallMutableArray-    {-# INLINE copyMutableArr #-}--    moveArr marr1 s1 marr2 s2 l-        | l <= 0 = return ()-        | sameMutableArr marr1 marr2 =-            case compare s1 s2 of-                LT ->-                    let !d = s2 - s1-                        !s2l = s2 + l-                        go !i | i >= s2l = return ()-                              | otherwise = do x <- readSmallArray marr2 i-                                               writeSmallArray marr1 (i-d) x-                                               go (i+1)-                    in go s2--                EQ -> return ()--                GT ->-                    let !d = s1 - s2-                        go !i | i < s2 = return ()-                              | otherwise = do x <- readSmallArray marr2 i-                                               writeSmallArray marr1 (i+d) x-                                               go (i-1)-                    in go (s2+l-1)-        | otherwise = copySmallMutableArray marr1 s1 marr2 s2 l-    {-# INLINE moveArr #-}--    cloneArr = cloneSmallArray-    {-# INLINE cloneArr #-}-    cloneMutableArr = cloneSmallMutableArray-    {-# INLINE cloneMutableArr #-}--    resizeMutableArr marr n = do-        marr' <- newSmallArray n uninitialized-        copySmallMutableArray marr' 0 marr 0 (sizeofSmallMutableArray marr)-        return marr'-    {-# INLINE resizeMutableArr #-}-#if MIN_VERSION_base(4,14,0)-    shrinkMutableArr = shrinkSmallMutableArray-#else-    shrinkMutableArr _ _ = return ()-#endif-    {-# INLINE shrinkMutableArr #-}--    sameMutableArr (SmallMutableArray smarr1#) (SmallMutableArray smarr2#) =-        isTrue# (sameSmallMutableArray# smarr1# smarr2#)-    {-# INLINE sameMutableArr #-}-    sizeofArr = sizeofSmallArray-    {-# INLINE sizeofArr #-}-    sizeofMutableArr = return . sizeofSmallMutableArray-    {-# INLINE sizeofMutableArr #-}--    sameArr (SmallArray arr1#) (SmallArray arr2#) = isTrue# (-        sameSmallMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#))-    {-# INLINE sameArr #-}--instance Prim a => Arr PrimArray a where-    type MArr PrimArray = MutablePrimArray-    newArr = newPrimArray-    {-# INLINE newArr #-}-    newArrWith n x = do-        marr <- newPrimArray n-        when (n > 0) (setPrimArray marr 0 n x)-        return marr-    {-# INLINE newArrWith #-}-    readArr = readPrimArray-    {-# INLINE readArr #-}-    writeArr = writePrimArray-    {-# INLINE writeArr #-}-    setArr = setPrimArray-    {-# INLINE setArr #-}-    indexArr = indexPrimArray-    {-# INLINE indexArr #-}-    indexArr' arr i = (# indexPrimArray arr i #)-    {-# INLINE indexArr' #-}-    indexArrM arr i = return (indexPrimArray arr i)-    {-# INLINE indexArrM #-}-    freezeArr = freezePrimArray-    {-# INLINE freezeArr #-}-    thawArr arr s l = do-        marr' <- newPrimArray l-        copyPrimArray marr' 0 arr s l-        return marr'-    {-# INLINE thawArr #-}-    unsafeFreezeArr = unsafeFreezePrimArray-    {-# INLINE unsafeFreezeArr #-}-    unsafeThawArr = unsafeThawPrimArray-    {-# INLINE unsafeThawArr #-}--    copyArr = copyPrimArray-    {-# INLINE copyArr #-}-    copyMutableArr = copyMutablePrimArray-    {-# INLINE copyMutableArr #-}--    moveArr (MutablePrimArray dst) doff (MutablePrimArray src) soff n =-        moveByteArray (MutableByteArray dst) (doff*siz) (MutableByteArray src) (soff*siz) (n*siz)-      where siz = sizeOf (undefined :: a)-    {-# INLINE moveArr #-}--    cloneArr = clonePrimArray-    {-# INLINE cloneArr #-}-    cloneMutableArr = cloneMutablePrimArray-    {-# INLINE cloneMutableArr #-}--    resizeMutableArr = resizeMutablePrimArray-    {-# INLINE resizeMutableArr #-}-    shrinkMutableArr = shrinkMutablePrimArray-    {-# INLINE shrinkMutableArr #-}--    sameMutableArr = sameMutablePrimArray-    {-# INLINE sameMutableArr #-}-    sizeofArr = sizeofPrimArray-    {-# INLINE sizeofArr #-}-    sizeofMutableArr = getSizeofMutablePrimArray-    {-# INLINE sizeofMutableArr #-}--    sameArr (PrimArray ba1#) (PrimArray ba2#) =-        isTrue# (sameMutableByteArray# (unsafeCoerce# ba1#) (unsafeCoerce# ba2#))-    {-# INLINE sameArr #-}--instance PrimUnlifted a => Arr UnliftedArray a where-    type MArr UnliftedArray = MutableUnliftedArray-    newArr = unsafeNewUnliftedArray-    {-# INLINE newArr #-}-    newArrWith = newUnliftedArray-    {-# INLINE newArrWith #-}-    readArr = readUnliftedArray-    {-# INLINE readArr #-}-    writeArr = writeUnliftedArray-    {-# INLINE writeArr #-}-    setArr = setUnliftedArray-    {-# INLINE setArr #-}-    indexArr = indexUnliftedArray-    {-# INLINE indexArr #-}-    indexArr' arr i = (# indexUnliftedArray arr i #)-    {-# INLINE indexArr' #-}-    indexArrM arr i = return (indexUnliftedArray arr i)-    {-# INLINE indexArrM #-}-    freezeArr = freezeUnliftedArray-    {-# INLINE freezeArr #-}-    thawArr = thawUnliftedArray-    {-# INLINE thawArr #-}-    unsafeFreezeArr = unsafeFreezeUnliftedArray-    {-# INLINE unsafeFreezeArr #-}-    unsafeThawArr (UnliftedArray arr#) = primitive ( \ s0# ->-            let !(# s1#, marr# #) = unsafeThawArray# (unsafeCoerce# arr#) s0#-                                                        -- ArrayArray# and Array# use the same representation-            in (# s1#, MutableUnliftedArray (unsafeCoerce# marr#) #)    -- so this works-        )-    {-# INLINE unsafeThawArr #-}--    copyArr = copyUnliftedArray-    {-# INLINE copyArr #-}-    copyMutableArr = copyMutableUnliftedArray-    {-# INLINE copyMutableArr #-}--    moveArr marr1 s1 marr2 s2 l-        | l <= 0 = return ()-        | sameMutableUnliftedArray marr1 marr2 =-            case compare s1 s2 of-                LT ->-                    let !d = s2 - s1-                        !s2l = s2 + l-                        go !i | i >= s2l = return ()-                              | otherwise = do x <- readUnliftedArray marr2 i-                                               writeUnliftedArray marr1 (i-d) x-                                               go (i+1)-                    in go s2--                EQ -> return ()--                GT ->-                    let !d = s1 - s2-                        go !i | i < s2 = return ()-                              | otherwise = do x <- readUnliftedArray marr2 i-                                               writeUnliftedArray marr1 (i+d) x-                                               go (i-1)-                    in go (s2+l-1)-        | otherwise = copyMutableUnliftedArray marr1 s1 marr2 s2 l-    {-# INLINE moveArr #-}--    cloneArr = cloneUnliftedArray-    {-# INLINE cloneArr #-}-    cloneMutableArr = cloneMutableUnliftedArray-    {-# INLINE cloneMutableArr #-}--    resizeMutableArr marr n = do-        marr' <- newUnliftedArray n uninitialized-        copyMutableUnliftedArray marr' 0 marr 0 (sizeofMutableUnliftedArray marr)-        return marr'-    {-# INLINE resizeMutableArr #-}-    shrinkMutableArr _ _ = return ()-    {-# INLINE shrinkMutableArr #-}--    sameMutableArr = sameMutableUnliftedArray-    {-# INLINE sameMutableArr #-}-    sizeofArr = sizeofUnliftedArray-    {-# INLINE sizeofArr #-}-    sizeofMutableArr = return . sizeofMutableUnliftedArray-    {-# INLINE sizeofMutableArr #-}--    sameArr (UnliftedArray arr1#) (UnliftedArray arr2#) = isTrue# (-        sameMutableArrayArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#))-    {-# INLINE sameArr #-}-------------------------------------------------------------------------------------- | Obtain the pointer to the content of an array, and the pointer should only be used during the IO action.------ This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or--- 'newAlignedPinnedPrimArray').------ Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.-withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b-{-# INLINE withPrimArrayContents #-}-withPrimArrayContents (PrimArray ba#) f = do-    let addr# = byteArrayContents# ba#-        ptr = Ptr addr#-    b <- f ptr-    primitive_ (touch# ba#)-    return b---- | Obtain the pointer to the content of an mutable array, and the pointer should only be used during the IO action.------ This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or--- 'newAlignedPinnedPrimArray').------ Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.-withMutablePrimArrayContents :: MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b-{-# INLINE withMutablePrimArrayContents #-}-withMutablePrimArrayContents (MutablePrimArray mba#) f = do-    let addr# = byteArrayContents# (unsafeCoerce# mba#)-        ptr = Ptr addr#-    b <- f ptr-    primitive_ (touch# mba#)-    return b----- | Cast between arrays-castArray :: (Arr arr a, Cast a b) => arr a -> arr b-castArray = unsafeCoerce#----- | Cast between mutable arrays-castMutableArray :: (Arr arr a, Cast a b) => MArr arr s a -> MArr arr s b-castMutableArray = unsafeCoerce#------------------------------------------------------------------------------------emptyArr :: Arr arr a => arr a-emptyArr = runST $ do-    marr <- newArrWith 0 uninitialized-    unsafeFreezeArr marr--singletonArr :: Arr arr a => a -> arr a-{-# INLINE singletonArr #-}-singletonArr x = runST $ do-    marr <- newArrWith 1 x-    unsafeFreezeArr marr--doubletonArr :: Arr arr a => a -> a -> arr a-{-# INLINE doubletonArr #-}-doubletonArr x y = runST $ do-    marr <- newArrWith 2 x-    writeArr marr 1 y-    unsafeFreezeArr marr---- | Modify(strictly) an immutable some elements of an array with specified subrange.--- This function will produce a new array.-modifyIndexArr :: Arr arr a-               => arr a-               -> Int        -- ^ offset-               -> Int        -- ^ length-               -> Int        -- ^ index in new array-               -> (a -> a)   -- ^ modify function-               -> arr a-{-# INLINE modifyIndexArr #-}-modifyIndexArr arr off len ix f = runST $ do-    marr <- unsafeThawArr (cloneArr arr off len)-    !v <- f <$> readArr marr ix-    writeArr marr ix v-    unsafeFreezeArr marr---- | Insert a value to an immutable array at given index. This function will produce a new array.-insertIndexArr :: Arr arr a-               => arr a-               -> Int        -- ^ offset-               -> Int        -- ^ length-               -> Int        -- ^ insert index in new array-               -> a          -- ^ value to be inserted-               -> arr a-{-# INLINE insertIndexArr #-}-insertIndexArr arr s l i x = runST $ do-    marr <- newArrWith (l+1) x-    when (i>0) $ copyArr marr 0 arr s i-    when (i<l) $ copyArr marr (i+1) arr (i+s) (l-i)-    unsafeFreezeArr marr---- | Delete an element of the immutable array's at given index. This function will produce a new array.-deleteIndexArr :: Arr arr a-               => arr a-               -> Int        -- ^ offset-               -> Int        -- ^ length-               -> Int        -- ^ the index of the element to delete-               -> arr a-{-# INLINE deleteIndexArr #-}-deleteIndexArr arr s l i = runST $ do-    marr <- newArr (l-1)-    when (i>0) $ copyArr marr 0 arr s i-    let i' = i+1-    when (i'<l) $ copyArr marr i arr (i'+s) (l-i')-    unsafeFreezeArr marr+Module      : Z.Data.Array.Checked+Description : Bounded checked boxed and unboxed arrays+Copyright   : (c) Dong Han, 2017-2019+License     : BSD+Maintainer  : winterland1989@gmail.com+Stability   : experimental+Portability : non-portable++Unified unboxed and boxed array operations using type family. This module re-export "Z.Data.Array.Base" module, but add check+when @check-array-bound@ flag is set. To debug array algorithms just add @Z-Data: -f+check-array-bound@ to your local @cabal.project@ file.+otherwise, none of the operations are bound checked.++Some mnemonics:++  * 'newArr' and 'newArrWith' return mutable array.+    'readArr' and 'writeArr' perform read and write actions on mutable arrays.+    'setArr' fills the elements with offset and length.+    'indexArr' only works on immutable Array, use 'indexArr'' to avoid thunks building up in the heap.++  * 'freezeArr' and 'thawArr' make a copy thus need slicing params.+    'unsafeFreezeArr' and 'unsafeThawArr' DO NOT COPY, use with care.++  * The order of arguements of 'copyArr', 'copyMutableArr' and 'moveArr' are always target and its offset+    come first, and source and source offset follow, copying length comes last.++-}+module Z.Data.Array+  ( -- * Arr typeclass re-export+    Arr, MArr+  , A.emptyArr, A.singletonArr, A.doubletonArr+  , modifyIndexArr, insertIndexArr, deleteIndexArr+  , RealWorld+  -- * Boxed array type+  , A.Array(..)+  , A.MutableArray(..)+  , A.SmallArray(..)+  , A.SmallMutableArray(..)+  , A.uninitialized+  -- * Primitive array type+  , A.PrimArray(..)+  , A.MutablePrimArray(..)+  , Prim(..)+  -- * Bound checked array operations+  , newArr+  , newArrWith+  , readArr+  , writeArr+  , setArr+  , indexArr+  , indexArr'+  , indexArrM+  , freezeArr+  , thawArr+  , copyArr+  , copyMutableArr+  , moveArr+  , cloneArr+  , cloneMutableArr+  , resizeMutableArr+  , shrinkMutableArr+  -- * No bound checked operations+  , A.unsafeFreezeArr+  , A.unsafeThawArr+  , A.sameMutableArr+  , A.sizeofArr+  , A.sizeofMutableArr+  , A.sameArr+  -- * Bound checked primitive array operations+  , newPinnedPrimArray, newAlignedPinnedPrimArray+  , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray+  -- * No bound checked primitive array operations+  , A.primArrayContents, A.mutablePrimArrayContents, A.withPrimArrayContents, A.withMutablePrimArrayContents+  , A.isPrimArrayPinned, A.isMutablePrimArrayPinned+  -- * Unlifted array type+  , A.UnliftedArray(..)+  , A.MutableUnliftedArray(..)+  , A.PrimUnlifted(..)+  -- * The 'ArrayException' type+  , ArrayException(..)+  -- * Cast between primitive arrays+  , A.Cast+  , A.castArray+  , A.castMutableArray+  -- * Re-export+  , sizeOf+  ) where++import           Control.Exception              (ArrayException (..), throw)+import           Control.Monad.Primitive+import           Data.Primitive.Types+import           GHC.Stack+import           Z.Data.Array.Base      (Arr, MArr)+import qualified Z.Data.Array.Base      as A+#ifdef CHECK_ARRAY_BOUND+import           Control.Monad+import           Control.Monad.ST+#endif++#ifdef CHECK_ARRAY_BOUND+check :: HasCallStack => Bool -> a -> a+{-# INLINE check #-}+check True  x = x+check False _ = throw (IndexOutOfBounds $ show callStack)+#endif++-- | Make a new array with a given size.+--+-- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed.+-- For primitive arrays, elements are just random garbage.+newArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+       => Int -> m (MArr arr s a)+newArr n =+#ifdef CHECK_ARRAY_BOUND+    check  (n>=0) (A.newArr n)+#else+    A.newArr n+#endif+{-# INLINE newArr #-}++-- | Make a new array and fill it with an initial value.+newArrWith :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+           => Int -> a -> m (MArr arr s a)+newArrWith n x =+#ifdef CHECK_ARRAY_BOUND+    check  (n>=0) (A.newArrWith n x)+#else+    (A.newArrWith n x)+#endif+{-# INLINE newArrWith #-}++-- | Read from specified index of mutable array in a primitive monad.+readArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+        => MArr arr s a -> Int -> m a+readArr marr i = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (i>=0 && i<siz)+        (A.readArr marr i)+#else+        (A.readArr marr i)+#endif+{-# INLINE readArr #-}++-- | Write to specified index of mutable array in a primitive monad.+writeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+         => MArr arr s a -> Int -> a -> m ()+writeArr marr i x = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (i>=0 && i<siz)+        (A.writeArr marr i x)+#else+        (A.writeArr marr i x)+#endif+{-# INLINE writeArr #-}++-- | Fill the mutable array with a given value.+setArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+       => MArr arr s a -> Int -> Int -> a -> m ()+setArr marr s l x = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (s>=0 && l>=0 && (s+l)<=siz)+        (A.setArr marr s l x)+#else+        (A.setArr marr s l x)+#endif+{-# INLINE setArr #-}++-- | Read from the specified index of an immutable array. It's pure and often+-- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this.+indexArr :: (Arr arr a, HasCallStack)+         => arr a -> Int -> a+indexArr arr i =+#ifdef CHECK_ARRAY_BOUND+    check (i>=0 && i<A.sizeofArr arr) (A.indexArr arr i)+#else+    (A.indexArr arr i)+#endif+{-# INLINE indexArr #-}++-- | Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated.+-- Pattern matching on the tuple forces the indexing of the array to happen but does not evaluate the element itself.+-- Evaluating the thunk prevents additional thunks from building up on the heap.+-- Avoiding these thunks, in turn, reduces references to the argument array, allowing it to be garbage collected more promptly.+indexArr' :: (Arr arr a, HasCallStack)+          => arr a -> Int -> (# a #)+indexArr' arr i =+#ifdef CHECK_ARRAY_BOUND+    if (i>=0 && i<A.sizeofArr arr)+    then A.indexArr' arr i+    else throw (IndexOutOfBounds $ show callStack)+#else+    (A.indexArr' arr i)+#endif+{-# INLINE indexArr' #-}++-- | Monadically read a value from the immutable array at the given index.+-- This allows us to be strict in the array while remaining lazy in the read+-- element which is very useful for collective operations. Suppose we want to+-- copy an array. We could do something like this:+--+-- > copy marr arr ... = do ...+-- >                        writeArray marr i (indexArray arr i) ...+-- >                        ...+--+-- But since primitive arrays are lazy, the calls to 'indexArray' will not be+-- evaluated. Rather, @marr@ will be filled with thunks each of which would+-- retain a reference to @arr@. This is definitely not what we want!+--+-- With 'indexArrayM', we can instead write+--+-- > copy marr arr ... = do ...+-- >                        x <- indexArrayM arr i+-- >                        writeArray marr i x+-- >                        ...+--+-- Now, indexing is executed immediately although the returned element is+-- still not evaluated.+--+-- /Note:/ this function does not do bounds checking.+indexArrM :: (Arr arr a, Monad m, HasCallStack)+          => arr a -> Int -> m a+indexArrM arr i =+#ifdef CHECK_ARRAY_BOUND+    check+        (i>=0 && i<A.sizeofArr arr)+        (A.indexArrM arr i)+#else+        (A.indexArrM arr i)+#endif+{-# INLINE indexArrM #-}++-- | Create an immutable copy of a slice of an array.+-- This operation makes a copy of the specified section, so it is safe to continue using the mutable array afterward.+freezeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+          => MArr arr s a -> Int -> Int -> m (arr a)+freezeArr marr s l = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (s>=0 && l>=0 && (s+l)<=siz)+        (A.freezeArr marr s l)+#else+        (A.freezeArr marr s l)+#endif+{-# INLINE freezeArr #-}++-- | Create a mutable array from a slice of an immutable array.+-- This operation makes a copy of the specified slice, so it is safe to use the immutable array afterward.+thawArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+        => arr a -> Int -> Int -> m (MArr arr s a)+thawArr arr s l =+#ifdef CHECK_ARRAY_BOUND+    check+        (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr)+        (A.thawArr arr s l)+#else+    (A.thawArr arr s l)+#endif+{-# INLINE thawArr #-}++-- | Copy a slice of an immutable array to a mutable array at given offset.+copyArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+        => MArr arr s a -> Int -> arr a -> Int -> Int -> m ()+copyArr marr s1 arr s2 l = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (s1>=0 && s2>=0 && l>=0 && (s2+l)<=A.sizeofArr arr && (s1+l)<=siz)+        (A.copyArr marr s1 arr s2 l)+#else+        (A.copyArr marr s1 arr s2 l)+#endif+{-# INLINE copyArr #-}++-- | Copy a slice of a mutable array to another mutable array at given offset.+-- The two mutable arrays must not be the same.+copyMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+               => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m ()+copyMutableArr marr1 s1 marr2 s2 l = do+#ifdef CHECK_ARRAY_BOUND+    siz1 <- A.sizeofMutableArr marr1+    siz2 <- A.sizeofMutableArr marr2+    check+        (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1)+        (A.copyMutableArr marr1 s1 marr2 s2 l)+#else+        (A.copyMutableArr marr1 s1 marr2 s2 l)+#endif+{-# INLINE copyMutableArr #-}++-- | Copy a slice of a mutable array to a mutable array at given offset.+-- The two mutable arrays can be the same.+moveArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+        => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m ()+moveArr marr1 s1 marr2 s2 l = do+#ifdef CHECK_ARRAY_BOUND+    siz1 <- A.sizeofMutableArr marr1+    siz2 <- A.sizeofMutableArr marr2+    check+        (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1)+        (A.moveArr marr1 s1 marr2 s2 l)+#else+        (A.moveArr marr1 s1 marr2 s2 l)+#endif+{-# INLINE moveArr #-}++-- | Create an immutable copy with the given subrange of the original array.+cloneArr :: (Arr arr a, HasCallStack)+         => arr a -> Int -> Int -> arr a+cloneArr arr s l =+#ifdef CHECK_ARRAY_BOUND+    check+        (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr)+        (A.cloneArr arr s l)+#else+    (A.cloneArr arr s l)+#endif+{-# INLINE cloneArr #-}++-- | Create a mutable copy the given subrange of the original array.+cloneMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+                => MArr arr s a -> Int -> Int -> m (MArr arr s a)+cloneMutableArr marr s l = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (s>=0 && l>=0 && (s+l)<=siz)+        (A.cloneMutableArr marr s l)+#else+        (A.cloneMutableArr marr s l)+#endif+{-# INLINE cloneMutableArr #-}++-- | Resize a mutable array to the given size.+resizeMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+                 => MArr arr s a -> Int -> m (MArr arr s a)+resizeMutableArr marr n =+#ifdef CHECK_ARRAY_BOUND+    check (n>=0) (A.resizeMutableArr marr n)+#else+    (A.resizeMutableArr marr n)+#endif+{-# INLINE resizeMutableArr #-}++-- | Shrink a mutable array to the given size. This operation only works on primitive arrays.+-- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change.+--+-- New size should be >= 0, and <= original size.+shrinkMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+                 => MArr arr s a -> Int -> m ()+shrinkMutableArr marr n = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (n>=0 && n<=siz)+        (A.shrinkMutableArr marr n)+#else+        (A.shrinkMutableArr marr n)+#endif+{-# INLINE shrinkMutableArr #-}++--------------------------------------------------------------------------------++-- | Create a /pinned/ byte array of the specified size,+-- The garbage collector is guaranteed not to move it.+newPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack)+                   => Int -> m (A.MutablePrimArray (PrimState m) a)+{-# INLINE newPinnedPrimArray #-}+newPinnedPrimArray n =+#ifdef CHECK_ARRAY_BOUND+    check  (n>=0) (A.newPinnedPrimArray n)+#else+    (A.newPinnedPrimArray n)+#endif++-- | Create a /pinned/ primitive array of the specified size and respect given primitive type's+-- alignment. The garbage collector is guaranteed not to move it.+--+newAlignedPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack)+                          => Int -> m (A.MutablePrimArray (PrimState m) a)+{-# INLINE newAlignedPinnedPrimArray #-}+newAlignedPinnedPrimArray n =+#ifdef CHECK_ARRAY_BOUND+    check  (n>=0) (A.newAlignedPinnedPrimArray n)+#else+    (A.newAlignedPinnedPrimArray n)+#endif++copyPrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack)+                   => Ptr a+                   -> A.PrimArray a+                   -> Int+                   -> Int+                   -> m ()+{-# INLINE copyPrimArrayToPtr #-}+copyPrimArrayToPtr ptr arr s l =+#ifdef CHECK_ARRAY_BOUND+    check+        (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr)+        (A.copyPrimArrayToPtr ptr arr s l)+#else+    (A.copyPrimArrayToPtr ptr arr s l)+#endif++copyMutablePrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack)+                          => Ptr a+                          -> A.MutablePrimArray (PrimState m) a+                          -> Int+                          -> Int+                          -> m ()+{-# INLINE copyMutablePrimArrayToPtr #-}+copyMutablePrimArrayToPtr ptr marr s l = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (s>=0 && l>=0 && (s+l)<=siz)+        (A.copyMutablePrimArrayToPtr ptr marr s l)+#else+    (A.copyMutablePrimArrayToPtr ptr marr s l)+#endif++copyPtrToMutablePrimArray :: (PrimMonad m, Prim a, HasCallStack)+                            => A.MutablePrimArray (PrimState m) a+                            -> Int+                            -> Ptr a+                            -> Int+                            -> m ()+{-# INLINE copyPtrToMutablePrimArray #-}+copyPtrToMutablePrimArray marr s ptr l = do+#ifdef CHECK_ARRAY_BOUND+    siz <- A.sizeofMutableArr marr+    check+        (s>=0 && l>=0 && (s+l)<=siz)+        (A.copyPtrToMutablePrimArray marr s ptr l)+#else+        (A.copyPtrToMutablePrimArray marr s ptr l)+#endif++--------------------------------------------------------------------------------++modifyIndexArr :: (Arr arr a, HasCallStack) => arr a+               -> Int    -- ^ offset+               -> Int    -- ^ length+               -> Int    -- ^ index in new array+               -> (a -> a)   -- ^ modify function+               -> arr a+{-# INLINE modifyIndexArr #-}+modifyIndexArr arr off len ix f =+#ifdef CHECK_ARRAY_BOUND+    runST $ do+        marr <- A.unsafeThawArr (cloneArr arr off len)+        !v <- f <$> readArr marr ix+        writeArr marr ix v+        A.unsafeFreezeArr marr+#else+    A.modifyIndexArr arr off len ix f+#endif++-- | Insert an immutable array's element at given index to produce a new array.+insertIndexArr :: Arr arr a+               => arr a+               -> Int        -- ^ offset+               -> Int        -- ^ length+               -> Int        -- ^ insert index in new array+               -> a          -- ^ element to be inserted+               -> arr a+{-# INLINE insertIndexArr #-}+insertIndexArr arr s l i x =+#ifdef CHECK_ARRAY_BOUND+    runST $ do+        marr <- newArrWith (l+1) x+        when (i>0) $ copyArr marr 0 arr s i+        when (i<l) $ copyArr marr (i+1) arr (i+s) (l-i)+        A.unsafeFreezeArr marr+#else+    A.insertIndexArr arr s l i x+#endif++-- | Drop an immutable array's element at given index to produce a new array.+deleteIndexArr :: Arr arr a+               => arr a+               -> Int        -- ^ offset+               -> Int        -- ^ length+               -> Int        -- ^ drop index in new array+               -> arr a+{-# INLINE deleteIndexArr #-}+deleteIndexArr arr s l i =+#ifdef CHECK_ARRAY_BOUND+    runST $ do+        marr <- newArr (l-1)+        when (i>0) $ copyArr marr 0 arr s i+        let i' = i+1+        when (i'<l) $ copyArr marr i arr (i'+s) (l-i')+        A.unsafeFreezeArr marr+#else+    A.deleteIndexArr arr s l i+#endif

@@ -0,0 +1,692 @@+{-|+Module      : Z.Data.Array+Description : Fast boxed and unboxed arrays+Copyright   : (c) Dong Han, 2017+License     : BSD+Maintainer  : winterland1989@gmail.com+Stability   : experimental+Portability : non-portable++Unified unboxed and boxed array operations using type family.++NONE of the operations are bound checked, if you need checked operations please use "Z.Data.Array.Checked" instead.+It exports the exact same APIs ,so it requires no extra effort to switch between them.++Some mnemonics:++  * 'newArr' and 'newArrWith' return mutable array.+    'readArr' and 'writeArr' perform read and write actions on mutable arrays.+    'setArr' fills the elements with offset and length.+    'indexArr' only works on immutable Array, use 'indexArr'' to avoid thunks building up in the heap.++  * 'freezeArr' and 'thawArr' make a copy thus need slicing params.+    'unsafeFreezeArr' and 'unsafeThawArr' DO NOT COPY, use with care.++  * The order of arguements of 'copyArr', 'copyMutableArr' and 'moveArr' are always target and its offset+    come first, and source and source offset follow, copying length comes last.+-}++module Z.Data.Array.Base (+  -- * Arr typeclass+    Arr(..)+  , emptyArr, singletonArr, doubletonArr+  , modifyIndexArr, insertIndexArr, deleteIndexArr+  , RealWorld+  -- * Boxed array type+  , Array(..)+  , MutableArray(..)+  , SmallArray(..)+  , SmallMutableArray(..)+  , uninitialized+  -- * Primitive array type+  , PrimArray(..)+  , MutablePrimArray(..)+  , Prim(..)+  -- * Primitive array operations+  , newPinnedPrimArray, newAlignedPinnedPrimArray+  , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray+  , primArrayContents, mutablePrimArrayContents, withPrimArrayContents, withMutablePrimArrayContents+  , isPrimArrayPinned, isMutablePrimArrayPinned+  -- * Unlifted array type+  , UnliftedArray(..)+  , MutableUnliftedArray(..)+  , PrimUnlifted(..)+  -- * The 'ArrayException' type+  , ArrayException(..)+  -- * Cast between primitive arrays+  , Cast+  , castArray+  , castMutableArray+  -- * Re-export+  , sizeOf+  ) where++import           Control.Exception              (ArrayException (..), throw)+import           Control.Monad+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Data.Kind                      (Type)+import           Data.Primitive.Array+import           Data.Primitive.ByteArray+import           Data.Primitive.PrimArray+import           Data.Primitive.Ptr             (copyPtrToMutablePrimArray)+import           Data.Primitive.SmallArray+import           Data.Primitive.Types+import           GHC.Exts+import           Z.Data.Array.Cast+import           Z.Data.Array.UnliftedArray+++-- | Bottom value (@throw ('UndefinedElement' 'Data.Array.uninitialized')@)+-- for new boxed array('Array', 'SmallArray'..) initialization.+--+uninitialized :: a+uninitialized = throw (UndefinedElement "Data.Array.uninitialized")+++-- | The typeclass that unifies box & unboxed and mutable & immutable array operations.+--+-- Most of these functions simply wrap their primitive counterpart.+-- When there are no primitive ones, we fulfilled the semantic with other operations.+--+-- One exception is 'shrinkMutableArr' which only performs closure resizing on 'PrimArray', because+-- currently, RTS only supports that. 'shrinkMutableArr' won't do anything on other array types.+--+-- It's reasonable to trust GHC to specialize & inline these polymorphic functions.+-- They are used across this package and perform identically to their monomorphic counterpart.+--+class Arr (arr :: Type -> Type) a where+++    -- | The mutable version of this array type.+    --+    type MArr arr = (mar :: Type -> Type -> Type) | mar -> arr+++    -- | Make a new array with a given size.+    --+    -- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed.+    -- For primitive arrays, elements are just random garbage.+    newArr :: (PrimMonad m, PrimState m ~ s) => Int -> m (MArr arr s a)+++    -- | Make a new array and fill it with an initial value.+    newArrWith :: (PrimMonad m, PrimState m ~ s) => Int -> a -> m (MArr arr s a)+++    -- | Read from specified index of mutable array in a primitive monad.+    readArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m a+++    -- | Write to specified index of mutable array in a primitive monad.+    writeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> a -> m ()+++    -- | Fill the mutable array with a given value.+    setArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> a -> m ()+++    -- | Read from the specified index of an immutable array. It's pure and often+    -- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this.+    indexArr :: arr a -> Int -> a+++    -- | Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated.+    -- Pattern matching on the tuple forces the indexing of the array to happen but does not evaluate the element itself.+    -- Evaluating the thunk prevents additional thunks from building up on the heap.+    -- Avoiding these thunks, in turn, reduces references to the argument array, allowing it to be garbage collected more promptly.+    indexArr' :: arr a -> Int -> (# a #)+++    -- | Monadically read a value from the immutable array at the given index.+    -- This allows us to be strict in the array while remaining lazy in the read+    -- element which is very useful for collective operations. Suppose we want to+    -- copy an array. We could do something like this:+    --+    -- > copy marr arr ... = do ...+    -- >                        writeArray marr i (indexArray arr i) ...+    -- >                        ...+    --+    -- But since primitive arrays are lazy, the calls to 'indexArray' will not be+    -- evaluated. Rather, @marr@ will be filled with thunks each of which would+    -- retain a reference to @arr@. This is definitely not what we want!+    --+    -- With 'indexArrayM', we can instead write+    --+    -- > copy marr arr ... = do ...+    -- >                        x <- indexArrayM arr i+    -- >                        writeArray marr i x+    -- >                        ...+    --+    -- Now, indexing is executed immediately although the returned element is+    -- still not evaluated.+    --+    -- /Note:/ this function does not do bounds checking.+    indexArrM :: (Monad m) => arr a -> Int -> m a+++    -- | Create an immutable copy of a slice of an array.+    -- This operation makes a copy of the specified section, so it is safe to continue using the mutable array afterward.+    freezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (arr a)+++    -- | Create a mutable array from a slice of an immutable array.+    -- This operation makes a copy of the specified slice, so it is safe to use the immutable array afterward.+    thawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> Int -> Int -> m (MArr arr s a)+++    -- | Convert a mutable array to an immutable one without copying.+    -- The array should not be modified after the conversion.+    unsafeFreezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m (arr a)++++    -- | Convert a mutable array to an immutable one without copying. The+    -- array should not be modified after the conversion.+    unsafeThawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> m (MArr arr s a)+++    -- | Copy a slice of an immutable array to a mutable array at given offset.+    copyArr ::  (PrimMonad m, PrimState m ~ s)+            => MArr arr s a -- ^ target+            -> Int          -- ^ offset into target array+            -> arr a        -- ^ source+            -> Int          -- ^ offset into source array+            -> Int          -- ^ number of elements to copy+            -> m ()+++    -- | Copy a slice of a mutable array to another mutable array at given offset.+    -- The two mutable arrays must not be the same.+    copyMutableArr :: (PrimMonad m, PrimState m ~ s)+                   => MArr arr s a  -- ^ target+                   -> Int           -- ^ offset into target array+                   -> MArr arr s a  -- ^ source+                   -> Int           -- ^ offset into source array+                   -> Int           -- ^ number of elements to copy+                   -> m ()+++    -- | Copy a slice of a mutable array to a mutable array at given offset.+    -- The two mutable arrays can be the same.+    moveArr :: (PrimMonad m, PrimState m ~ s)+            => MArr arr s a  -- ^ target+            -> Int           -- ^ offset into target array+            -> MArr arr s a  -- ^ source+            -> Int           -- ^ offset into source array+            -> Int           -- ^ number of elements to copy+            -> m ()+++    -- | Create an immutable copy with the given subrange of the original array.+    cloneArr :: arr a -> Int -> Int -> arr a+++    -- | Create a mutable copy the given subrange of the original array.+    cloneMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (MArr arr s a)+++    -- | Resize a mutable array to the given size.+    resizeMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m (MArr arr s a)+++    -- | Shrink a mutable array to the given size. This operation only works on primitive arrays.+    -- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change.+    shrinkMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m ()+++    -- | Is two mutable array are reference equal.+    sameMutableArr :: MArr arr s a -> MArr arr s a -> Bool+++    -- | Size of the immutable array.+    sizeofArr :: arr a -> Int+++    -- | Size of the mutable array.+    sizeofMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m Int+++    -- | Check whether the two immutable arrays refer to the same memory block+    --+    -- Note that the result of 'sameArr' may change depending on compiler's optimizations, for example,+    -- @let arr = runST ... in arr `sameArr` arr@ may return false if compiler decides to+    -- inline it.+    --+    -- See https://ghc.haskell.org/trac/ghc/ticket/13908 for more context.+    --+    sameArr :: arr a -> arr a -> Bool++instance Arr Array a where+    type MArr Array = MutableArray+    newArr n = newArray n uninitialized+    {-# INLINE newArr #-}+    newArrWith = newArray+    {-# INLINE newArrWith #-}+    readArr = readArray+    {-# INLINE readArr #-}+    writeArr = writeArray+    {-# INLINE writeArr #-}+    setArr marr s l x = go s+      where+        !sl = s + l+        go !i | i >= sl = return ()+              | otherwise = writeArray marr i x >> go (i+1)+    {-# INLINE setArr #-}+    indexArr = indexArray+    {-# INLINE indexArr #-}+    indexArr' (Array arr#) (I# i#) = indexArray# arr# i#+    {-# INLINE indexArr' #-}+    indexArrM = indexArrayM+    {-# INLINE indexArrM #-}+    freezeArr = freezeArray+    {-# INLINE freezeArr #-}+    thawArr = thawArray+    {-# INLINE thawArr #-}+    unsafeFreezeArr = unsafeFreezeArray+    {-# INLINE unsafeFreezeArr #-}+    unsafeThawArr = unsafeThawArray+    {-# INLINE unsafeThawArr #-}++    copyArr = copyArray+    {-# INLINE copyArr #-}+    copyMutableArr = copyMutableArray+    {-# INLINE copyMutableArr #-}++    moveArr marr1 s1 marr2 s2 l+        | l <= 0 = return ()+        | sameMutableArray marr1 marr2 =+            case compare s1 s2 of+                LT ->+                    let !d = s2 - s1+                        !s2l = s2 + l+                        go !i | i >= s2l = return ()+                              | otherwise = do x <- readArray marr2 i+                                               writeArray marr1 (i-d) x+                                               go (i+1)+                    in go s2++                EQ -> return ()++                GT ->+                    let !d = s1 - s2+                        go !i | i < s2 = return ()+                              | otherwise = do x <- readArray marr2 i+                                               writeArray marr1 (i+d) x+                                               go (i-1)+                    in go (s2+l-1)+        | otherwise = copyMutableArray marr1 s1 marr2 s2 l+    {-# INLINE moveArr #-}++    cloneArr = cloneArray+    {-# INLINE cloneArr #-}+    cloneMutableArr = cloneMutableArray+    {-# INLINE cloneMutableArr #-}++    resizeMutableArr marr n = do+        marr' <- newArray n uninitialized+        copyMutableArray marr' 0 marr 0 (sizeofMutableArray marr)+        return marr'+    {-# INLINE resizeMutableArr #-}+    shrinkMutableArr _ _ = return ()+    {-# INLINE shrinkMutableArr #-}++    sameMutableArr = sameMutableArray+    {-# INLINE sameMutableArr #-}+    sizeofArr = sizeofArray+    {-# INLINE sizeofArr #-}+    sizeofMutableArr = return . sizeofMutableArray+    {-# INLINE sizeofMutableArr #-}++    sameArr (Array arr1#) (Array arr2#) = isTrue# (+        sameMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#))+    {-# INLINE sameArr #-}++instance Arr SmallArray a where+    type MArr SmallArray = SmallMutableArray+    newArr n = newSmallArray n uninitialized+    {-# INLINE newArr #-}+    newArrWith = newSmallArray+    {-# INLINE newArrWith #-}+    readArr = readSmallArray+    {-# INLINE readArr #-}+    writeArr = writeSmallArray+    {-# INLINE writeArr #-}+    setArr marr s l x = go s+      where+        !sl = s + l+        go !i | i >= sl = return ()+              | otherwise = writeSmallArray marr i x >> go (i+1)+    {-# INLINE setArr #-}+    indexArr = indexSmallArray+    {-# INLINE indexArr #-}+    indexArr' (SmallArray arr#) (I# i#) = indexSmallArray# arr# i#+    {-# INLINE indexArr' #-}+    indexArrM = indexSmallArrayM+    {-# INLINE indexArrM #-}+    freezeArr = freezeSmallArray+    {-# INLINE freezeArr #-}+    thawArr = thawSmallArray+    {-# INLINE thawArr #-}+    unsafeFreezeArr = unsafeFreezeSmallArray+    {-# INLINE unsafeFreezeArr #-}+    unsafeThawArr = unsafeThawSmallArray+    {-# INLINE unsafeThawArr #-}++    copyArr = copySmallArray+    {-# INLINE copyArr #-}+    copyMutableArr = copySmallMutableArray+    {-# INLINE copyMutableArr #-}++    moveArr marr1 s1 marr2 s2 l+        | l <= 0 = return ()+        | sameMutableArr marr1 marr2 =+            case compare s1 s2 of+                LT ->+                    let !d = s2 - s1+                        !s2l = s2 + l+                        go !i | i >= s2l = return ()+                              | otherwise = do x <- readSmallArray marr2 i+                                               writeSmallArray marr1 (i-d) x+                                               go (i+1)+                    in go s2++                EQ -> return ()++                GT ->+                    let !d = s1 - s2+                        go !i | i < s2 = return ()+                              | otherwise = do x <- readSmallArray marr2 i+                                               writeSmallArray marr1 (i+d) x+                                               go (i-1)+                    in go (s2+l-1)+        | otherwise = copySmallMutableArray marr1 s1 marr2 s2 l+    {-# INLINE moveArr #-}++    cloneArr = cloneSmallArray+    {-# INLINE cloneArr #-}+    cloneMutableArr = cloneSmallMutableArray+    {-# INLINE cloneMutableArr #-}++    resizeMutableArr marr n = do+        marr' <- newSmallArray n uninitialized+        copySmallMutableArray marr' 0 marr 0 (sizeofSmallMutableArray marr)+        return marr'+    {-# INLINE resizeMutableArr #-}+#if MIN_VERSION_base(4,14,0)+    shrinkMutableArr = shrinkSmallMutableArray+#else+    shrinkMutableArr _ _ = return ()+#endif+    {-# INLINE shrinkMutableArr #-}++    sameMutableArr (SmallMutableArray smarr1#) (SmallMutableArray smarr2#) =+        isTrue# (sameSmallMutableArray# smarr1# smarr2#)+    {-# INLINE sameMutableArr #-}+    sizeofArr = sizeofSmallArray+    {-# INLINE sizeofArr #-}+    sizeofMutableArr = return . sizeofSmallMutableArray+    {-# INLINE sizeofMutableArr #-}++    sameArr (SmallArray arr1#) (SmallArray arr2#) = isTrue# (+        sameSmallMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#))+    {-# INLINE sameArr #-}++instance Prim a => Arr PrimArray a where+    type MArr PrimArray = MutablePrimArray+    newArr = newPrimArray+    {-# INLINE newArr #-}+    newArrWith n x = do+        marr <- newPrimArray n+        when (n > 0) (setPrimArray marr 0 n x)+        return marr+    {-# INLINE newArrWith #-}+    readArr = readPrimArray+    {-# INLINE readArr #-}+    writeArr = writePrimArray+    {-# INLINE writeArr #-}+    setArr = setPrimArray+    {-# INLINE setArr #-}+    indexArr = indexPrimArray+    {-# INLINE indexArr #-}+    indexArr' arr i = (# indexPrimArray arr i #)+    {-# INLINE indexArr' #-}+    indexArrM arr i = return (indexPrimArray arr i)+    {-# INLINE indexArrM #-}+    freezeArr = freezePrimArray+    {-# INLINE freezeArr #-}+    thawArr arr s l = do+        marr' <- newPrimArray l+        copyPrimArray marr' 0 arr s l+        return marr'+    {-# INLINE thawArr #-}+    unsafeFreezeArr = unsafeFreezePrimArray+    {-# INLINE unsafeFreezeArr #-}+    unsafeThawArr = unsafeThawPrimArray+    {-# INLINE unsafeThawArr #-}++    copyArr = copyPrimArray+    {-# INLINE copyArr #-}+    copyMutableArr = copyMutablePrimArray+    {-# INLINE copyMutableArr #-}++    moveArr (MutablePrimArray dst) doff (MutablePrimArray src) soff n =+        moveByteArray (MutableByteArray dst) (doff*siz) (MutableByteArray src) (soff*siz) (n*siz)+      where siz = sizeOf (undefined :: a)+    {-# INLINE moveArr #-}++    cloneArr = clonePrimArray+    {-# INLINE cloneArr #-}+    cloneMutableArr = cloneMutablePrimArray+    {-# INLINE cloneMutableArr #-}++    resizeMutableArr = resizeMutablePrimArray+    {-# INLINE resizeMutableArr #-}+    shrinkMutableArr = shrinkMutablePrimArray+    {-# INLINE shrinkMutableArr #-}++    sameMutableArr = sameMutablePrimArray+    {-# INLINE sameMutableArr #-}+    sizeofArr = sizeofPrimArray+    {-# INLINE sizeofArr #-}+    sizeofMutableArr = getSizeofMutablePrimArray+    {-# INLINE sizeofMutableArr #-}++    sameArr (PrimArray ba1#) (PrimArray ba2#) =+        isTrue# (sameMutableByteArray# (unsafeCoerce# ba1#) (unsafeCoerce# ba2#))+    {-# INLINE sameArr #-}++instance PrimUnlifted a => Arr UnliftedArray a where+    type MArr UnliftedArray = MutableUnliftedArray+    newArr = unsafeNewUnliftedArray+    {-# INLINE newArr #-}+    newArrWith = newUnliftedArray+    {-# INLINE newArrWith #-}+    readArr = readUnliftedArray+    {-# INLINE readArr #-}+    writeArr = writeUnliftedArray+    {-# INLINE writeArr #-}+    setArr = setUnliftedArray+    {-# INLINE setArr #-}+    indexArr = indexUnliftedArray+    {-# INLINE indexArr #-}+    indexArr' arr i = (# indexUnliftedArray arr i #)+    {-# INLINE indexArr' #-}+    indexArrM arr i = return (indexUnliftedArray arr i)+    {-# INLINE indexArrM #-}+    freezeArr = freezeUnliftedArray+    {-# INLINE freezeArr #-}+    thawArr = thawUnliftedArray+    {-# INLINE thawArr #-}+    unsafeFreezeArr = unsafeFreezeUnliftedArray+    {-# INLINE unsafeFreezeArr #-}+    unsafeThawArr (UnliftedArray arr#) = primitive ( \ s0# ->+            let !(# s1#, marr# #) = unsafeThawArray# (unsafeCoerce# arr#) s0#+                                                        -- ArrayArray# and Array# use the same representation+            in (# s1#, MutableUnliftedArray (unsafeCoerce# marr#) #)    -- so this works+        )+    {-# INLINE unsafeThawArr #-}++    copyArr = copyUnliftedArray+    {-# INLINE copyArr #-}+    copyMutableArr = copyMutableUnliftedArray+    {-# INLINE copyMutableArr #-}++    moveArr marr1 s1 marr2 s2 l+        | l <= 0 = return ()+        | sameMutableUnliftedArray marr1 marr2 =+            case compare s1 s2 of+                LT ->+                    let !d = s2 - s1+                        !s2l = s2 + l+                        go !i | i >= s2l = return ()+                              | otherwise = do x <- readUnliftedArray marr2 i+                                               writeUnliftedArray marr1 (i-d) x+                                               go (i+1)+                    in go s2++                EQ -> return ()++                GT ->+                    let !d = s1 - s2+                        go !i | i < s2 = return ()+                              | otherwise = do x <- readUnliftedArray marr2 i+                                               writeUnliftedArray marr1 (i+d) x+                                               go (i-1)+                    in go (s2+l-1)+        | otherwise = copyMutableUnliftedArray marr1 s1 marr2 s2 l+    {-# INLINE moveArr #-}++    cloneArr = cloneUnliftedArray+    {-# INLINE cloneArr #-}+    cloneMutableArr = cloneMutableUnliftedArray+    {-# INLINE cloneMutableArr #-}++    resizeMutableArr marr n = do+        marr' <- newUnliftedArray n uninitialized+        copyMutableUnliftedArray marr' 0 marr 0 (sizeofMutableUnliftedArray marr)+        return marr'+    {-# INLINE resizeMutableArr #-}+    shrinkMutableArr _ _ = return ()+    {-# INLINE shrinkMutableArr #-}++    sameMutableArr = sameMutableUnliftedArray+    {-# INLINE sameMutableArr #-}+    sizeofArr = sizeofUnliftedArray+    {-# INLINE sizeofArr #-}+    sizeofMutableArr = return . sizeofMutableUnliftedArray+    {-# INLINE sizeofMutableArr #-}++    sameArr (UnliftedArray arr1#) (UnliftedArray arr2#) = isTrue# (+        sameMutableArrayArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#))+    {-# INLINE sameArr #-}++--------------------------------------------------------------------------------++-- | Obtain the pointer to the content of an array, and the pointer should only be used during the IO action.+--+-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or+-- 'newAlignedPinnedPrimArray').+--+-- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b+{-# INLINE withPrimArrayContents #-}+withPrimArrayContents (PrimArray ba#) f = do+    let addr# = byteArrayContents# ba#+        ptr = Ptr addr#+    b <- f ptr+    primitive_ (touch# ba#)+    return b++-- | Obtain the pointer to the content of an mutable array, and the pointer should only be used during the IO action.+--+-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or+-- 'newAlignedPinnedPrimArray').+--+-- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+withMutablePrimArrayContents :: MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b+{-# INLINE withMutablePrimArrayContents #-}+withMutablePrimArrayContents (MutablePrimArray mba#) f = do+    let addr# = byteArrayContents# (unsafeCoerce# mba#)+        ptr = Ptr addr#+    b <- f ptr+    primitive_ (touch# mba#)+    return b++-- | Cast between arrays+castArray :: (Arr arr a, Cast a b) => arr a -> arr b+{-# INLINE castArray #-}+castArray = unsafeCoerce#+++-- | Cast between mutable arrays+castMutableArray :: (Arr arr a, Cast a b) => MArr arr s a -> MArr arr s b+{-# INLINE castMutableArray #-}+castMutableArray = unsafeCoerce#++--------------------------------------------------------------------------------++emptyArr :: Arr arr a => arr a+{-# NOINLINE emptyArr #-}+emptyArr = runST $ do+    marr <- newArrWith 0 uninitialized+    unsafeFreezeArr marr++singletonArr :: Arr arr a => a -> arr a+{-# INLINE singletonArr #-}+singletonArr x = runST $ do+    marr <- newArrWith 1 x+    unsafeFreezeArr marr++doubletonArr :: Arr arr a => a -> a -> arr a+{-# INLINE doubletonArr #-}+doubletonArr x y = runST $ do+    marr <- newArrWith 2 x+    writeArr marr 1 y+    unsafeFreezeArr marr++-- | Modify(strictly) an immutable some elements of an array with specified subrange.+-- This function will produce a new array.+modifyIndexArr :: Arr arr a+               => arr a+               -> Int        -- ^ offset+               -> Int        -- ^ length+               -> Int        -- ^ index in new array+               -> (a -> a)   -- ^ modify function+               -> arr a+{-# INLINE modifyIndexArr #-}+modifyIndexArr arr off len ix f = runST $ do+    marr <- unsafeThawArr (cloneArr arr off len)+    !v <- f <$> readArr marr ix+    writeArr marr ix v+    unsafeFreezeArr marr++-- | Insert a value to an immutable array at given index. This function will produce a new array.+insertIndexArr :: Arr arr a+               => arr a+               -> Int        -- ^ offset+               -> Int        -- ^ length+               -> Int        -- ^ insert index in new array+               -> a          -- ^ value to be inserted+               -> arr a+{-# INLINE insertIndexArr #-}+insertIndexArr arr s l i x = runST $ do+    marr <- newArrWith (l+1) x+    when (i>0) $ copyArr marr 0 arr s i+    when (i<l) $ copyArr marr (i+1) arr (i+s) (l-i)+    unsafeFreezeArr marr++-- | Delete an element of the immutable array's at given index. This function will produce a new array.+deleteIndexArr :: Arr arr a+               => arr a+               -> Int        -- ^ offset+               -> Int        -- ^ length+               -> Int        -- ^ the index of the element to delete+               -> arr a+{-# INLINE deleteIndexArr #-}+deleteIndexArr arr s l i = runST $ do+    marr <- newArr (l-1)+    when (i>0) $ copyArr marr 0 arr s i+    let i' = i+1+    when (i'<l) $ copyArr marr i arr (i'+s) (l-i')+    unsafeFreezeArr marr

@@ -36,49 +36,67 @@     cast = coerce  instance Cast Int8  Word8 where+    {-# INLINE cast #-}     cast (I8# i) = W8# (narrow8Word# (int2Word# i)) instance Cast Int16 Word16 where+    {-# INLINE cast #-}     cast (I16# i) = W16# (narrow16Word# (int2Word# i)) instance Cast Int32 Word32 where+    {-# INLINE cast #-}     cast (I32# i) = W32# (narrow32Word# (int2Word# i)) instance Cast Int64 Word64 where+    {-# INLINE cast #-} #if WORD_SIZE_IN_BITS < 64     cast (I64# i) = W64# (int64ToWord64# i) #else     cast (I64# i) = W64# (int2Word# i) #endif instance Cast Int   Word where+    {-# INLINE cast #-}     cast (I# i) = W# (int2Word# i)  instance Cast Word8  Int8 where+    {-# INLINE cast #-}     cast (W8# i) = I8# (narrow8Int# (word2Int# i)) instance Cast Word16 Int16 where+    {-# INLINE cast #-}     cast (W16# i) = I16# (narrow16Int# (word2Int# i)) instance Cast Word32 Int32 where+    {-# INLINE cast #-}     cast (W32# i) = I32# (narrow32Int# (word2Int# i)) instance Cast Word64 Int64 where+    {-# INLINE cast #-} #if WORD_SIZE_IN_BITS < 64     cast (W64# i) = I64# (word64ToInt64# i) #else     cast (W64# i) = I64# (word2Int# i) #endif instance Cast Word   Int where+    {-# INLINE cast #-}     cast (W# w) = I# (word2Int# w)  instance Cast Word64 Double where+    {-# INLINE cast #-}     cast = castWord64ToDouble instance Cast Word32 Float where+    {-# INLINE cast #-}     cast = castWord32ToFloat instance Cast Double Word64 where+    {-# INLINE cast #-}     cast = castDoubleToWord64 instance Cast Float Word32 where+    {-# INLINE cast #-}     cast = castFloatToWord32  instance Cast Int64 Double where+    {-# INLINE cast #-}     cast = castWord64ToDouble . cast instance Cast Int32 Float where+    {-# INLINE cast #-}     cast = castWord32ToFloat . cast instance Cast Double Int64 where+    {-# INLINE cast #-}     cast = cast . castDoubleToWord64 instance Cast Float Int32 where+    {-# INLINE cast #-}     cast = cast . castFloatToWord32

@@ -1,328 +0,0 @@-{-|-Module      : Z.Data.Array.Checked-Description : Bounded checked boxed and unboxed arrays-Copyright   : (c) Dong Han, 2017-2019-License     : BSD-Maintainer  : winterland1989@gmail.com-Stability   : experimental-Portability : non-portable--This module provides exactly the same API with "Z.Data.Array", but will throw an 'IndexOutOfBounds'-'ArrayException' on bound check failure, it's useful when debugging array algorithms: just swap this-module with "Z.Data.Array", segmentation faults caused by out bound access will be turned into exceptions-with more informations.---}-module Z.Data.Array.Checked-  ( -- * Arr typeclass re-export-    Arr, MArr-  , A.emptyArr, A.singletonArr, A.doubletonArr-  , modifyIndexArr, insertIndexArr, deleteIndexArr-  , RealWorld-  -- * Boxed array type-  , A.Array(..)-  , A.MutableArray(..)-  , A.SmallArray(..)-  , A.SmallMutableArray(..)-  , A.uninitialized-  -- * Primitive array type-  , A.PrimArray(..)-  , A.MutablePrimArray(..)-  , Prim(..)-  -- * Bound checked array operations-  , newArr-  , newArrWith-  , readArr-  , writeArr-  , setArr-  , indexArr-  , indexArr'-  , indexArrM-  , freezeArr-  , thawArr-  , copyArr-  , copyMutableArr-  , moveArr-  , cloneArr-  , cloneMutableArr-  , resizeMutableArr-  , shrinkMutableArr-  -- * No bound checked operations-  , A.unsafeFreezeArr-  , A.unsafeThawArr-  , A.sameMutableArr-  , A.sizeofArr-  , A.sizeofMutableArr-  , A.sameArr-  -- * Bound checked primitive array operations-  , newPinnedPrimArray, newAlignedPinnedPrimArray-  , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray-  -- * No bound checked primitive array operations-  , A.primArrayContents, A.mutablePrimArrayContents, A.withPrimArrayContents, A.withMutablePrimArrayContents-  , A.isPrimArrayPinned, A.isMutablePrimArrayPinned-  -- * Unlifted array type-  , A.UnliftedArray(..)-  , A.MutableUnliftedArray(..)-  , A.PrimUnlifted(..)-  -- * The 'ArrayException' type-  , ArrayException(..)-  -- * Cast between primitive arrays-  , A.Cast-  , A.castArray-  , A.castMutableArray-  -- * Re-export-  , sizeOf-  ) where--import           Control.Exception       (ArrayException (..), throw)-import           Control.Monad-import           Control.Monad.Primitive-import           Control.Monad.ST-import           Data.Primitive.Types-import           GHC.Stack-import           Z.Data.Array          (Arr, MArr)-import qualified Z.Data.Array          as A--check :: HasCallStack => Bool -> a -> a-{-# INLINE check #-}-check True  x = x-check False _ = throw (IndexOutOfBounds $ show callStack)--newArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-       => Int -> m (MArr arr s a)-newArr n = check  (n>=0) (A.newArr n)-{-# INLINE newArr #-}--newArrWith :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-           => Int -> a -> m (MArr arr s a)-newArrWith n x = check  (n>=0) (A.newArrWith n x)-{-# INLINE newArrWith #-}--readArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-        => MArr arr s a -> Int -> m a-readArr marr i = do-    siz <- A.sizeofMutableArr marr-    check-        (i>=0 && i<siz)-        (A.readArr marr i)-{-# INLINE readArr #-}--writeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-         => MArr arr s a -> Int -> a -> m ()-writeArr marr i x = do-    siz <- A.sizeofMutableArr marr-    check-        (i>=0 && i<siz)-        (A.writeArr marr i x)-{-# INLINE writeArr #-}--setArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-       => MArr arr s a -> Int -> Int -> a -> m ()-setArr marr s l x = do-    siz <- A.sizeofMutableArr marr-    check-        (s>=0 && l>=0 && (s+l)<=siz)-        (A.setArr marr s l x)-{-# INLINE setArr #-}--indexArr :: (Arr arr a, HasCallStack)-         => arr a -> Int -> a-indexArr arr i = check-    (i>=0 && i<A.sizeofArr arr)-    (A.indexArr arr i)-{-# INLINE indexArr #-}--indexArr' :: (Arr arr a, HasCallStack)-          => arr a -> Int -> (# a #)-indexArr' arr i =-    if (i>=0 && i<A.sizeofArr arr)-    then A.indexArr' arr i-    else throw (IndexOutOfBounds $ show callStack)-{-# INLINE indexArr' #-}--indexArrM :: (Arr arr a, Monad m, HasCallStack)-          => arr a -> Int -> m a-indexArrM arr i = check-    (i>=0 && i<A.sizeofArr arr)-    (A.indexArrM arr i)-{-# INLINE indexArrM #-}--freezeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-          => MArr arr s a -> Int -> Int -> m (arr a)-freezeArr marr s l = do-    siz <- A.sizeofMutableArr marr-    check-        (s>=0 && l>=0 && (s+l)<=siz)-        (A.freezeArr marr s l)-{-# INLINE freezeArr #-}--thawArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-        => arr a -> Int -> Int -> m (MArr arr s a)-thawArr arr s l = check-    (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr)-    (A.thawArr arr s l)-{-# INLINE thawArr #-}--copyArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-        => MArr arr s a -> Int -> arr a -> Int -> Int -> m ()-copyArr marr s1 arr s2 l = do-    siz <- A.sizeofMutableArr marr-    check-        (s1>=0 && s2>=0 && l>=0 && (s2+l)<=A.sizeofArr arr && (s1+l)<=siz)-        (A.copyArr marr s1 arr s2 l)-{-# INLINE copyArr #-}--copyMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-               => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m ()-copyMutableArr marr1 s1 marr2 s2 l = do-    siz1 <- A.sizeofMutableArr marr1-    siz2 <- A.sizeofMutableArr marr2-    check-        (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1)-        (A.copyMutableArr marr1 s1 marr2 s2 l)-{-# INLINE copyMutableArr #-}--moveArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-        => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m ()-moveArr marr1 s1 marr2 s2 l = do-    siz1 <- A.sizeofMutableArr marr1-    siz2 <- A.sizeofMutableArr marr2-    check-        (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1)-        (A.copyMutableArr marr1 s1 marr2 s2 l)-{-# INLINE moveArr #-}--cloneArr :: (Arr arr a, HasCallStack)-         => arr a -> Int -> Int -> arr a-cloneArr arr s l = check-    (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr)-    (A.cloneArr arr s l)-{-# INLINE cloneArr #-}--cloneMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-                => MArr arr s a -> Int -> Int -> m (MArr arr s a)-cloneMutableArr marr s l = do-    siz <- A.sizeofMutableArr marr-    check-        (s>=0 && l>=0 && (s+l)<=siz)-        (A.cloneMutableArr marr s l)-{-# INLINE cloneMutableArr #-}--resizeMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-                 => MArr arr s a -> Int -> m (MArr arr s a)-resizeMutableArr marr n = check-    (n>=0)-    (A.resizeMutableArr marr n)-{-# INLINE resizeMutableArr #-}---- | New size should be >= 0, and <= original size.----shrinkMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-                 => MArr arr s a -> Int -> m ()-shrinkMutableArr marr n = do-    siz <- A.sizeofMutableArr marr-    check-        (n>=0 && n<=siz)-        (A.shrinkMutableArr marr n)-{-# INLINE shrinkMutableArr #-}-------------------------------------------------------------------------------------- | Create a /pinned/ byte array of the specified size,--- The garbage collector is guaranteed not to move it.-newPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack)-                   => Int -> m (A.MutablePrimArray (PrimState m) a)-{-# INLINE newPinnedPrimArray #-}-newPinnedPrimArray n =-    check  (n>=0) (A.newPinnedPrimArray n)---- | Create a /pinned/ primitive array of the specified size and respect given primitive type's--- alignment. The garbage collector is guaranteed not to move it.----newAlignedPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack)-                          => Int -> m (A.MutablePrimArray (PrimState m) a)-{-# INLINE newAlignedPinnedPrimArray #-}-newAlignedPinnedPrimArray n =-    check  (n>=0) (A.newAlignedPinnedPrimArray n)--copyPrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack)-                   => Ptr a-                   -> A.PrimArray a-                   -> Int-                   -> Int-                   -> m ()-{-# INLINE copyPrimArrayToPtr #-}-copyPrimArrayToPtr ptr arr s l = check-    (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr)-    (A.copyPrimArrayToPtr ptr arr s l)--copyMutablePrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack)-                          => Ptr a-                          -> A.MutablePrimArray (PrimState m) a-                          -> Int-                          -> Int-                          -> m ()-{-# INLINE copyMutablePrimArrayToPtr #-}-copyMutablePrimArrayToPtr ptr marr s l = do-    siz <- A.sizeofMutableArr marr-    check-        (s>=0 && l>=0 && (s+l)<=siz)-        (A.copyMutablePrimArrayToPtr ptr marr s l)--copyPtrToMutablePrimArray :: (PrimMonad m, Prim a, HasCallStack)-                            => A.MutablePrimArray (PrimState m) a-                            -> Int-                            -> Ptr a-                            -> Int-                            -> m ()-{-# INLINE copyPtrToMutablePrimArray #-}-copyPtrToMutablePrimArray marr s ptr l = do-    siz <- A.sizeofMutableArr marr-    check-        (s>=0 && l>=0 && (s+l)<=siz)-        (A.copyPtrToMutablePrimArray marr s ptr l)------------------------------------------------------------------------------------modifyIndexArr :: (Arr arr a, HasCallStack) => arr a-               -> Int    -- ^ offset-               -> Int    -- ^ length-               -> Int    -- ^ index in new array-               -> (a -> a)   -- ^ modify function-               -> arr a-{-# INLINE modifyIndexArr #-}-modifyIndexArr arr off len ix f = runST $ do-    marr <- A.unsafeThawArr (cloneArr arr off len)-    !v <- f <$> readArr marr ix-    writeArr marr ix v-    A.unsafeFreezeArr marr---- | Insert an immutable array's element at given index to produce a new array.-insertIndexArr :: Arr arr a-               => arr a-               -> Int        -- ^ offset-               -> Int        -- ^ length-               -> Int        -- ^ insert index in new array-               -> a          -- ^ element to be inserted-               -> arr a-{-# INLINE insertIndexArr #-}-insertIndexArr arr s l i x = runST $ do-    marr <- newArrWith (l+1) x-    when (i>0) $ copyArr marr 0 arr s i-    when (i<l) $ copyArr marr (i+1) arr (i+s) (l-i)-    A.unsafeFreezeArr marr---- | Drop an immutable array's element at given index to produce a new array.-deleteIndexArr :: Arr arr a-               => arr a-               -> Int        -- ^ offset-               -> Int        -- ^ length-               -> Int        -- ^ drop index in new array-               -> arr a-{-# INLINE deleteIndexArr #-}-deleteIndexArr arr s l i = runST $ do-    marr <- newArr (l-1)-    when (i>0) $ copyArr marr 0 arr s i-    let i' = i+1-    when (i'<l) $ copyArr marr i arr (i'+s) (l-i')-    A.unsafeFreezeArr marr

@@ -113,13 +113,14 @@     (error "Cannot use arrASCII as a dec")  word8ArrayFromAddr :: Int -> Addr# -> PrimArray Word8-{-# INLINE word8ArrayFromAddr #-}+{-# INLINABLE word8ArrayFromAddr #-} word8ArrayFromAddr l addr# = runST $ do     mba <- newPrimArray l     copyPtrToMutablePrimArray mba 0 (Ptr addr#) l     unsafeFreezePrimArray mba  int8ArrayFromAddr :: Int -> Addr# -> PrimArray Int8+{-# INLINE int8ArrayFromAddr #-} int8ArrayFromAddr l addr# = castArray (word8ArrayFromAddr l addr#)  @@ -266,6 +267,7 @@     unsafeFreezePrimArray mba  int16ArrayFromAddr :: Int -> Addr# -> PrimArray Int16+{-# INLINE int16ArrayFromAddr #-} int16ArrayFromAddr l addr# = castArray (word16ArrayFromAddr l addr#)  ARRAY_LITERAL_DOC(Int16)@@ -331,6 +333,7 @@     unsafeFreezePrimArray mba  int32ArrayFromAddr :: Int -> Addr# -> PrimArray Int32+{-# INLINE int32ArrayFromAddr #-} int32ArrayFromAddr l addr# = castArray (word32ArrayFromAddr l addr#)  ARRAY_LITERAL_DOC(Int32)@@ -396,13 +399,14 @@     (error "Cannot use arrW64 as a dec")  word64ArrayFromAddr :: Int -> Addr# -> PrimArray Word64-{-# INLINE word64ArrayFromAddr #-}+{-# INLINABLE word64ArrayFromAddr #-} word64ArrayFromAddr l addr# = runST $ do     mba <- newArr l     copyPtrToMutablePrimArray mba 0 (Ptr addr#) l     unsafeFreezePrimArray mba  int64ArrayFromAddr :: Int -> Addr# -> PrimArray Int64+{-# INLINE int64ArrayFromAddr #-} int64ArrayFromAddr l addr# = castArray (word64ArrayFromAddr l addr#)  ARRAY_LITERAL_DOC(Int64)@@ -440,6 +444,7 @@ --------------------------------------------------------------------------------  wordArrayFromAddr :: Int -> Addr# -> PrimArray Word+{-# INLINE wordArrayFromAddr #-} wordArrayFromAddr l addr# = #if SIZEOF_HSWORD == 8     unsafeCoerce# (word64ArrayFromAddr l addr#)@@ -448,6 +453,7 @@ #endif  intArrayFromAddr :: Int -> Addr# -> PrimArray Int+{-# INLINE intArrayFromAddr #-} intArrayFromAddr l addr# = #if SIZEOF_HSWORD == 8     unsafeCoerce# (int64ArrayFromAddr l addr#)

@@ -186,7 +186,6 @@ -- newtype BE a = BE { getBE :: a } deriving (Show, Eq) - #define USE_HOST_IMPL(END) \     {-# INLINE writeWord8ArrayAs# #-}; \     writeWord8ArrayAs# mba# i# (END x) = writeWord8ArrayAs# mba# i# x; \

@@ -54,18 +54,18 @@     indexUnliftedArray# :: ArrayArray# -> Int# -> a  instance PrimUnlifted (PrimArray a) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (PrimArray x) = writeByteArrayArray# a i x     readUnliftedArray# a i s0 = case readByteArrayArray# a i s0 of         (# s1, x #) -> (# s1, PrimArray x #)     indexUnliftedArray# a i = PrimArray (indexByteArrayArray# a i)  instance PrimUnlifted ByteArray where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (ByteArray x) = writeByteArrayArray# a i x     readUnliftedArray# a i s0 = case readByteArrayArray# a i s0 of         (# s1, x #) -> (# s1, ByteArray x #)@@ -78,9 +78,9 @@ -- This also uses unsafeCoerce# to relax the constraints on the -- state token. The primitives in GHC.Prim are too restrictive. instance PrimUnlifted (MutableByteArray s) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (MutableByteArray x) =         writeMutableByteArrayArray# a i (unsafeCoerce# x)     readUnliftedArray# a i s0 = case readMutableByteArrayArray# a i s0 of@@ -90,9 +90,9 @@ -- See the note on the PrimUnlifted instance for MutableByteArray. -- The same uses of unsafeCoerce# happen here. instance PrimUnlifted (MutablePrimArray s a) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (MutablePrimArray x) =         writeMutableByteArrayArray# a i (unsafeCoerce# x)     readUnliftedArray# a i s0 = case readMutableByteArrayArray# a i s0 of@@ -100,9 +100,9 @@     indexUnliftedArray# a i = MutablePrimArray (unsafeCoerce# (indexByteArrayArray# a i))  instance PrimUnlifted (MVar a) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (MVar x) =         writeArrayArrayArray# a i (unsafeCoerce# x)     readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of@@ -110,9 +110,9 @@     indexUnliftedArray# a i = MVar (unsafeCoerce# (indexArrayArrayArray# a i))  instance PrimUnlifted (TVar a) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (TVar x) =         writeArrayArrayArray# a i (unsafeCoerce# x)     readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of@@ -120,9 +120,9 @@     indexUnliftedArray# a i = TVar (unsafeCoerce# (indexArrayArrayArray# a i))  instance PrimUnlifted (STRef s a) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (STRef x) =         writeArrayArrayArray# a i (unsafeCoerce# x)     readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of@@ -131,9 +131,9 @@         STRef (unsafeCoerce# (indexArrayArrayArray# a i))  instance PrimUnlifted (IORef a) where-    {-# inline writeUnliftedArray# #-}-    {-# inline readUnliftedArray# #-}-    {-# inline indexUnliftedArray# #-}+    {-# INLINE writeUnliftedArray# #-}+    {-# INLINE readUnliftedArray# #-}+    {-# INLINE indexUnliftedArray# #-}     writeUnliftedArray# a i (IORef v) = writeUnliftedArray# a i v     readUnliftedArray# a i s0 = case readUnliftedArray# a i s0 of         (# s1, v #) -> (# s1, IORef v #)@@ -157,7 +157,7 @@     :: (PrimMonad m)     => Int -- ^ size     -> m (MutableUnliftedArray (PrimState m) a)-{-# inline unsafeNewUnliftedArray #-}+{-# INLINE unsafeNewUnliftedArray #-} unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of     (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) @@ -172,7 +172,7 @@     mua <- unsafeNewUnliftedArray len     setUnliftedArray mua 0 len v     pure mua-{-# inline newUnliftedArray #-}+{-# INLINE newUnliftedArray #-}  setUnliftedArray     :: (PrimMonad m, PrimUnlifted a)@@ -181,7 +181,7 @@     -> Int -- ^ length     -> a -- ^ value to fill with     -> m ()-{-# inline setUnliftedArray #-}+{-# INLINE setUnliftedArray #-} setUnliftedArray mua off len v = loop (len + off - 1)   where     loop i@@ -190,12 +190,12 @@  -- | Yields the length of an 'UnliftedArray'. sizeofUnliftedArray :: UnliftedArray e -> Int-{-# inline sizeofUnliftedArray #-}+{-# INLINE sizeofUnliftedArray #-} sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#)  -- | Yields the length of a 'MutableUnliftedArray'. sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int-{-# inline sizeofMutableUnliftedArray #-}+{-# INLINE sizeofMutableUnliftedArray #-} sizeofMutableUnliftedArray (MutableUnliftedArray maa#)     = I# (sizeofMutableArrayArray# maa#) @@ -204,7 +204,7 @@     -> Int     -> a     -> m ()-{-# inline writeUnliftedArray #-}+{-# INLINE writeUnliftedArray #-} writeUnliftedArray (MutableUnliftedArray arr) (I# ix) a =     primitive_ (writeUnliftedArray# arr ix a) @@ -212,7 +212,7 @@     => MutableUnliftedArray (PrimState m) a     -> Int     -> m a-{-# inline readUnliftedArray #-}+{-# INLINE readUnliftedArray #-} readUnliftedArray (MutableUnliftedArray arr) (I# ix) =     primitive (readUnliftedArray# arr ix) @@ -220,7 +220,7 @@     => UnliftedArray a     -> Int     -> a-{-# inline indexUnliftedArray #-}+{-# INLINE indexUnliftedArray #-} indexUnliftedArray (UnliftedArray arr) (I# ix) =     indexUnliftedArray# arr ix @@ -234,7 +234,7 @@ unsafeFreezeUnliftedArray (MutableUnliftedArray maa#)     = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of         (# s', aa# #) -> (# s', UnliftedArray aa# #)-{-# inline unsafeFreezeUnliftedArray #-}+{-# INLINE unsafeFreezeUnliftedArray #-}  -- | Determines whether two 'MutableUnliftedArray' values are the same. This is -- object/pointer identity, not based on the contents.@@ -244,7 +244,7 @@     -> Bool sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#)     = isTrue# (sameMutableArrayArray# maa1# maa2#)-{-# inline sameMutableUnliftedArray #-}+{-# INLINE sameMutableUnliftedArray #-}  -- | Copies the contents of an immutable array into a mutable array. copyUnliftedArray@@ -255,7 +255,7 @@     -> Int -- ^ offset into source     -> Int -- ^ number of elements to copy     -> m ()-{-# inline copyUnliftedArray #-}+{-# INLINE copyUnliftedArray #-} copyUnliftedArray     (MutableUnliftedArray dst) (I# doff)     (UnliftedArray src) (I# soff) (I# ln) =@@ -271,7 +271,7 @@     -> Int -- ^ offset into source     -> Int -- ^ number of elements to copy     -> m ()-{-# inline copyMutableUnliftedArray #-}+{-# INLINE copyMutableUnliftedArray #-} copyMutableUnliftedArray     (MutableUnliftedArray dst) (I# doff)     (MutableUnliftedArray src) (I# soff) (I# ln) =@@ -291,7 +291,7 @@     dst <- unsafeNewUnliftedArray len     copyMutableUnliftedArray dst 0 src off len     unsafeFreezeUnliftedArray dst-{-# inline freezeUnliftedArray #-}+{-# INLINE freezeUnliftedArray #-}   -- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'.@@ -303,7 +303,7 @@     -> Int -- ^ offset     -> Int -- ^ length     -> m (MutableUnliftedArray (PrimState m) a)-{-# inline thawUnliftedArray #-}+{-# INLINE thawUnliftedArray #-} thawUnliftedArray src off len = do     dst <- unsafeNewUnliftedArray len     copyUnliftedArray dst 0 src off len@@ -315,7 +315,7 @@     -> Int -- ^ offset     -> Int -- ^ length     -> UnliftedArray a-{-# inline cloneUnliftedArray #-}+{-# INLINE cloneUnliftedArray #-} cloneUnliftedArray src off len = unsafeDupablePerformIO $ do     dst <- unsafeNewUnliftedArray len     copyUnliftedArray dst 0 src off len@@ -329,7 +329,7 @@     -> Int -- ^ offset     -> Int -- ^ length     -> m (MutableUnliftedArray (PrimState m) a)-{-# inline cloneMutableUnliftedArray #-}+{-# INLINE cloneMutableUnliftedArray #-} cloneMutableUnliftedArray src off len = do     dst <- unsafeNewUnliftedArray len     copyMutableUnliftedArray dst 0 src off len

@@ -64,8 +64,16 @@   , utcTime   , localTime   , zonedTime+    -- * Specialized primitive parser+  , encodeWord  , encodeWord64, encodeWord32, encodeWord16, encodeWord8+  , encodeInt   , encodeInt64 , encodeInt32 , encodeInt16 , encodeInt8 , encodeDouble, encodeFloat+  , encodeWordLE  , encodeWord64LE , encodeWord32LE , encodeWord16LE+  , encodeIntLE   , encodeInt64LE , encodeInt32LE , encodeInt16LE , encodeDoubleLE , encodeFloatLE+  , encodeWordBE  , encodeWord64BE , encodeWord32BE , encodeWord16BE+  , encodeIntBE   , encodeInt64BE , encodeInt32BE , encodeInt16BE , encodeDoubleBE , encodeFloatBE   ) where  import           Z.Data.Builder.Base import           Z.Data.Builder.Numeric import           Z.Data.Builder.Time+import           Prelude                        ()

@@ -50,6 +50,13 @@   , charUTF8, string7, char7, word7, string8, char8, word8, word8N, text   -- * Builder helpers   , paren, parenWhen, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList+    -- * Specialized primitive parser+  , encodeWord  , encodeWord64, encodeWord32, encodeWord16, encodeWord8+  , encodeInt   , encodeInt64 , encodeInt32 , encodeInt16 , encodeInt8 , encodeDouble, encodeFloat+  , encodeWordLE  , encodeWord64LE , encodeWord32LE , encodeWord16LE+  , encodeIntLE   , encodeInt64LE , encodeInt32LE , encodeInt16LE , encodeDoubleLE , encodeFloatLE+  , encodeWordBE  , encodeWord64BE , encodeWord32BE , encodeWord16BE+  , encodeIntBE   , encodeInt64BE , encodeInt32BE , encodeInt16BE , encodeDoubleBE , encodeFloatBE   ) where  import           Control.Monad@@ -64,10 +71,11 @@ import           Data.Primitive.PrimArray import           Z.Data.Array.Unaligned import           Z.Data.ASCII-import qualified Z.Data.Text.Base                 as T-import qualified Z.Data.Text.UTF8Codec            as T-import qualified Z.Data.Vector.Base               as V-import qualified Z.Data.Array                     as A+import qualified Z.Data.Text.Base                   as T+import qualified Z.Data.Text.UTF8Codec              as T+import qualified Z.Data.Vector.Base                 as V+import qualified Z.Data.Array                       as A+import           Prelude                            hiding (encodeFloat) import           System.IO.Unsafe import           Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) @@ -206,12 +214,12 @@  -- | Shortcut to 'buildWith' 'V.defaultInitSize'. build :: Builder a -> V.Bytes-{-# INLINE build #-}+{-# INLINABLE build #-} build = buildWith V.defaultInitSize  -- | Build some bytes and validate if it's UTF8 bytes. buildText :: HasCallStack => Builder a -> T.Text-{-# INLINE buildText #-}+{-# INLINABLE buildText #-} buildText = T.validate . buildWith V.defaultInitSize  -- | Build some bytes assuming it's UTF8 encoding.@@ -220,13 +228,13 @@ -- Check 'Z.Data.Text.ShowT' for UTF8 encoding builders. This functions is intended to -- be used in debug only. unsafeBuildText :: Builder a -> T.Text-{-# INLINE unsafeBuildText #-}+{-# INLINABLE unsafeBuildText #-} unsafeBuildText = T.Text . buildWith V.defaultInitSize  -- | Run Builder with doubling buffer strategy, which is suitable -- for building short bytes. buildWith :: Int -> Builder a -> V.Bytes-{-# INLINABLE buildWith #-}+{-# INLINE buildWith #-} buildWith initSiz (Builder b) = unsafePerformIO $ do     buf <- newPrimArray initSiz     loop =<< b (\ _ -> return . Done) (Buffer buf 0)@@ -249,7 +257,7 @@  -- | Shortcut to 'buildChunksWith' 'V.defaultChunkSize'. buildChunks :: Builder a -> [V.Bytes]-{-# INLINE buildChunks #-}+{-# INLINABLE buildChunks #-} buildChunks = buildChunksWith  V.smallChunkSize V.defaultChunkSize  -- | Run Builder with inserting chunk strategy, which is suitable@@ -257,7 +265,7 @@ -- -- Note the building process is lazy, building happens when list chunks are consumed. buildChunksWith :: Int -> Int -> Builder a -> [V.Bytes]-{-# INLINABLE buildChunksWith #-}+{-# INLINE buildChunksWith #-} buildChunksWith initSiz chunkSiz (Builder b) = unsafePerformIO $ do     buf <- newPrimArray initSiz     loop =<< b (\ _ -> return . Done) (Buffer buf 0)@@ -313,11 +321,19 @@ {-# INLINE writeN #-} writeN !n f = Builder (\ k buffer@(Buffer buf offset) -> do     siz <- getSizeofMutablePrimArray buf-    if n + offset <= siz-    then f buf offset >> k () (Buffer buf (offset+n))+    let n' = n + offset+    if n' <= siz+    then f buf offset >> k () (Buffer buf n')     else return (BufferFull buffer n (\ (Buffer buf' offset') -> do         f buf' offset' >> k () (Buffer buf' (offset'+n))))) +{- These rules are bascially what inliner do so no need to mess up with them+{-# RULES+  "ensureN/merge" forall n1 f1 n2 f2. append (ensureN n1 f1) (ensureN n2 f2) = ensureN (n1 + n2) (\ mba i -> f1 mba i >>= \ i' -> f2 mba i') #-}+{-# RULES+  "writeN/merge" forall n1 f1 n2 f2. append (writeN n1 f1) (writeN n2 f2) = writeN (n1 + n2) (\ mba i -> f1 mba i >> f2 mba (i+n1)) #-}+-}+ -- | Write a primitive type in host byte order. -- -- @@@ -326,53 +342,68 @@ -- @ encodePrim :: forall a. Unaligned a => a -> Builder () {-# INLINE encodePrim #-}-{-# SPECIALIZE INLINE encodePrim :: Word -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Word64 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Word32 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Word16 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Word8 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Int -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Int64 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Int32 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Int16 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Int8 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Double -> Builder () #-}-{-# SPECIALIZE INLINE encodePrim :: Float -> Builder () #-} encodePrim x = do     writeN n (\ mpa i -> writePrimWord8ArrayAs mpa i x)   where     n = getUnalignedSize (unalignedSize @a) +#define ENCODE_HOST(f, type) \+    f :: type -> Builder (); {-# INLINE f #-}; f = encodePrim; \+    -- ^ Encode type in host endian order.++ENCODE_HOST(encodeWord  , Word   )+ENCODE_HOST(encodeWord64, Word64 )+ENCODE_HOST(encodeWord32, Word32 )+ENCODE_HOST(encodeWord16, Word16 )+ENCODE_HOST(encodeWord8 , Word8  )+ENCODE_HOST(encodeInt   , Int    )+ENCODE_HOST(encodeInt64 , Int64  )+ENCODE_HOST(encodeInt32 , Int32  )+ENCODE_HOST(encodeInt16 , Int16  )+ENCODE_HOST(encodeInt8  , Int8   )+ENCODE_HOST(encodeDouble, Double )+ENCODE_HOST(encodeFloat , Float  )+ -- | Write a primitive type with little endianess. encodePrimLE :: forall a. Unaligned (LE a) => a -> Builder () {-# INLINE encodePrimLE #-}-{-# SPECIALIZE INLINE encodePrimLE :: Word -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Word64 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Word32 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Word16 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Int -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Int64 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Int32 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Int16 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Double -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimLE :: Float -> Builder () #-} encodePrimLE = encodePrim . LE +#define ENCODE_LE(f, type) \+    f :: type -> Builder (); {-# INLINE f #-}; f = encodePrimLE; \+    -- ^ Encode type in little endian order.++ENCODE_LE(encodeWordLE  , Word   )+ENCODE_LE(encodeWord64LE, Word64 )+ENCODE_LE(encodeWord32LE, Word32 )+ENCODE_LE(encodeWord16LE, Word16 )+ENCODE_LE(encodeIntLE   , Int    )+ENCODE_LE(encodeInt64LE , Int64  )+ENCODE_LE(encodeInt32LE , Int32  )+ENCODE_LE(encodeInt16LE , Int16  )+ENCODE_LE(encodeDoubleLE, Double )+ENCODE_LE(encodeFloatLE , Float  )+ -- | Write a primitive type with big endianess. encodePrimBE :: forall a. Unaligned (BE a) => a -> Builder () {-# INLINE encodePrimBE #-}-{-# SPECIALIZE INLINE encodePrimBE :: Word -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Word64 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Word32 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Word16 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Int -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Int64 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Int32 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Int16 -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Double -> Builder () #-}-{-# SPECIALIZE INLINE encodePrimBE :: Float -> Builder () #-} encodePrimBE = encodePrim . BE +#define ENCODE_BE(f, type) \+    f :: type -> Builder (); {-# INLINE f #-}; f = encodePrimBE; \+    -- ^ Encode type in little endian order.++ENCODE_BE(encodeWordBE  , Word   )+ENCODE_BE(encodeWord64BE, Word64 )+ENCODE_BE(encodeWord32BE, Word32 )+ENCODE_BE(encodeWord16BE, Word16 )+ENCODE_BE(encodeIntBE   , Int    )+ENCODE_BE(encodeInt64BE , Int64  )+ENCODE_BE(encodeInt32BE , Int32  )+ENCODE_BE(encodeInt16BE , Int16  )+ENCODE_BE(encodeDoubleBE, Double )+ENCODE_BE(encodeFloatBE , Float  )+ --------------------------------------------------------------------------------  -- | Turn 'String' into 'Builder' with UTF8 encoding@@ -403,7 +434,7 @@         writeN len (\ mba i -> copyPtrToMutablePrimArray mba i (Ptr addr#) len)  packUTF8Addr :: Addr# -> Builder ()-{-# INLINE packUTF8Addr #-}+{-# INLINABLE packUTF8Addr #-} packUTF8Addr addr0# = validateAndCopy addr0#   where     len = fromIntegral . unsafeDupablePerformIO $ V.c_strlen addr0#@@ -433,8 +464,7 @@ -- Codepoints beyond @'\x7F'@ will be chopped. char7 :: Char -> Builder () {-# INLINE char7 #-}-char7 chr =-    writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (c2w chr .&. 0x7F))+char7 chr = writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (c2w chr .&. 0x7F))  -- | Turn 'Word8' into 'Builder' with ASCII7 encoding --@@ -475,8 +505,7 @@ -- by this builder may not be legal UTF8 encoding bytes. word8N :: Int -> Word8 -> Builder () {-# INLINE word8N #-}-word8N x w8 = do-    writeN x (\ mpa i -> setPrimArray mpa i x w8)+word8N x w8 = writeN x (\ mpa i -> setPrimArray mpa i x w8)  -- | Write UTF8 encoded 'Text' using 'Builder'. --

@@ -84,6 +84,7 @@ {-# INLINE defaultIFormat #-} defaultIFormat = IFormat 0 NoPadding False +-- | Padding format. data Padding = NoPadding | RightSpacePadding | LeftSpacePadding | ZeroPadding deriving (Show, Eq, Ord, Enum)  instance Arbitrary Padding where@@ -147,7 +148,7 @@     pad = case padding of NoPadding          -> 0                           RightSpacePadding  -> 1                           LeftSpacePadding   -> 2-                          ZeroPadding        -> 3+                          _                  -> 3  -- | Internal formatting in haskell, it can be used with any bounded integral type. --@@ -463,13 +464,13 @@  -- | Decimal digit to ASCII digit. i2wDec :: (Integral a) => a -> Word8-{-# INLINE i2wDec #-}+{-# INLINABLE i2wDec #-} {-# SPECIALIZE INLINE i2wDec :: Int -> Word8 #-} i2wDec v = DIGIT_0 + fromIntegral v  -- | Hexadecimal digit to ASCII char. i2wHex :: (Integral a) => a -> Word8-{-# INLINE i2wHex #-}+{-# INLINABLE i2wHex #-} {-# SPECIALIZE INLINE i2wHex :: Int -> Word8 #-} i2wHex v     | v <= 9    = DIGIT_0 + fromIntegral v@@ -477,7 +478,7 @@  -- | Hexadecimal digit to UPPERCASED ASCII char. i2wHexUpper :: (Integral a) => a -> Word8-{-# INLINE i2wHexUpper #-}+{-# INLINABLE i2wHexUpper #-} {-# SPECIALIZE INLINE i2wHexUpper :: Int -> Word8 #-} i2wHexUpper v     | v <= 9    = DIGIT_0 + fromIntegral v@@ -502,7 +503,17 @@ -- @ -- hex :: forall a. (FiniteBits a, Integral a) => a -> Builder ()-{-# INLINE hex #-}+{-# INLINABLE hex #-}+{-# SPECIALIZE INLINE hex :: Int -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Int8 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Int16 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Int32 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Int64 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Word -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Word8 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Word16 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Word32 -> Builder () #-}+{-# SPECIALIZE INLINE hex :: Word64 -> Builder () #-} hex w = writeN hexSiz (go w (hexSiz-2))   where     bitSiz = finiteBitSize (undefined :: a)@@ -524,7 +535,17 @@  -- | The UPPERCASED version of 'hex'. hexUpper :: forall a. (FiniteBits a, Integral a) => a -> Builder ()-{-# INLINE hexUpper #-}+{-# INLINABLE hexUpper #-}+{-# SPECIALIZE INLINE hexUpper :: Int -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Int8 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Int16 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Int32 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Int64 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Word -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Word8 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Word16 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Word32 -> Builder () #-}+{-# SPECIALIZE INLINE hexUpper :: Word64 -> Builder () #-} hexUpper w = writeN hexSiz (go w (hexSiz-2))   where     bitSiz = finiteBitSize (undefined :: a)@@ -725,7 +746,7 @@  -- | Decimal encoding of a 'Double', note grisu only handles strictly positive finite numbers. grisu3 :: Double -> ([Int], Int)-{-# INLINE grisu3 #-}+{-# INLINABLE grisu3 #-} grisu3 d = unsafePerformIO $ do     (MutableByteArray pBuf) <- newByteArray GRISU3_DOUBLE_BUF_LEN     (len, (e, success)) <- allocPrimUnsafe $ \ pLen ->@@ -749,7 +770,7 @@  -- | Decimal encoding of a 'Float', note grisu3_sp only handles strictly positive finite numbers. grisu3_sp :: Float -> ([Int], Int)-{-# INLINE grisu3_sp #-}+{-# INLINABLE grisu3_sp #-} grisu3_sp d = unsafePerformIO $ do     (MutableByteArray pBuf) <- newByteArray GRISU3_SINGLE_BUF_LEN     (len, (e, success)) <- allocPrimUnsafe $ \ pLen ->

@@ -17,6 +17,7 @@ import           GHC.Word  decDigitTable :: Ptr Word16+{-# INLINABLE decDigitTable #-} decDigitTable = Ptr "0001020304050607080910111213141516171819\                      \2021222324252627282930313233343536373839\                      \4041424344454647484950515253545556575859\@@ -24,6 +25,7 @@                      \8081828384858687888990919293949596979899"#  hexDigitTable :: Ptr Word8+{-# INLINABLE hexDigitTable #-} hexDigitTable = Ptr "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f\                      \202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f\                      \404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f\@@ -34,6 +36,7 @@                      \e0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"#  hexDigitTableUpper :: Ptr Word8+{-# INLINABLE hexDigitTableUpper #-} hexDigitTableUpper = Ptr "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F\                           \202122232425262728292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F\                           \404142434445464748494A4B4C4D4E4F505152535455565758595A5B5C5D5E5F\

@@ -18,6 +18,10 @@   , utcTime   , localTime   , zonedTime+  -- * internal+  , twoDigits+  , toGregorian'+  , toGregorianInt64   ) where  import Control.Monad@@ -32,23 +36,63 @@ import Z.Data.ASCII  -- | @YYYY-mm-dd@.+-- day :: Day -> Builder () {-# INLINE day #-}-day dd = encodeYear yr <>-         B.encodePrim (HYPHEN, mh, ml, HYPHEN, dh, dl)-  where (yr, m, d)    = toGregorian dd-        (mh, ml)  = twoDigits m-        (dh, dl)  = twoDigits d-        encodeYear y-            | y >= 1000 = B.integer y-            | y >= 0    = B.encodePrim (padYear y)-            | y >= -999 = B.encodePrim (MINUS, padYear y)-            | otherwise = B.integer y-        padYear y =-            let (ab,c) = (fromIntegral y :: Int) `quotRem` 10-                (a, b)  = ab `quotRem` 10-            in (DIGIT_0, i2wDec a, i2wDec b, i2wDec c)+day dd = encodeYear yr <> B.encodePrim (HYPHEN, mh, ml, HYPHEN, dh, dl)+  where+    (yr, m, d)    = toGregorian' dd+    (mh, ml)  = twoDigits m+    (dh, dl)  = twoDigits d+    encodeYear y+        | y >= 1000 = B.integer y+        | y >= 0    = B.encodePrim (padYear y)+        | y >= -999 = B.encodePrim (MINUS, padYear y)+        | otherwise = B.integer y+    padYear y =+        let (ab,c) = (fromIntegral y :: Int) `quotRem` 10+            (a, b)  = ab `quotRem` 10+        in (DIGIT_0, i2wDec a, i2wDec b, i2wDec c) +-- | Faster 'toGregorian' with 'toGregorianInt64' as the common case path.+toGregorian' :: Day -> (Integer, Int, Int)+{-# INLINE toGregorian' #-}+toGregorian' dd@(ModifiedJulianDay mjd)+    | -9223372036854775808 <= mjd && mjd <= 9223372036854097232 = toGregorianInt64 (fromIntegral mjd)+    | otherwise = toGregorian dd++-- | Faster common case for small days (-9223372036854775808 ~ 9223372036854097232).+--+toGregorianInt64 :: Int64 -> (Integer, Int, Int)+{-# INLINABLE toGregorianInt64 #-}+toGregorianInt64 mjd = year' `seq` month `seq` day_ `seq` (year', month, day_)+  where+    a = mjd + 678575+    quadcent = div a 146097+    b = mod a 146097+    cent = min (div b 36524) 3+    c = b - (cent * 36524)+    quad = div c 1461+    d = mod c 1461+    y = min (div d 365) 3+    yd = fromIntegral (d - (y * 365) + 1)+    year = quadcent * 400 + cent * 100 + quad * 4 + y + 1+    year' = fromIntegral year+    isLeap = (rem year 4 == 0) && ((rem year 400 == 0) || not (rem year 100 == 0))+    (month, day_) = findMonthDay (if isLeap then monthListLeap else monthList) yd 1++    findMonthDay :: [Int] -> Int -> Int -> (Int, Int)+    findMonthDay (n : ns) !yd_ !m | yd_ > n = findMonthDay ns (yd_ - n) (m + 1)+    findMonthDay _ !yd_ !m                 = (m, yd_)++monthList :: [Int]+{-# NOINLINE monthList #-}+monthList = [ 31 , 28 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ]++monthListLeap :: [Int]+{-# NOINLINE monthListLeap #-}+monthListLeap = [ 31 , 29 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ]+ -- | @HH-MM-SS@. timeOfDay :: TimeOfDay -> Builder () {-# INLINE timeOfDay #-}@@ -103,7 +147,7 @@ dayTime d t = day d >> B.word8 LETTER_T >> timeOfDay64 t  timeOfDay64 :: TimeOfDay64 -> Builder ()-{-# INLINE timeOfDay64 #-}+{-# INLINABLE timeOfDay64 #-} timeOfDay64 (!h, !m, !s) = do     B.encodePrim (hh, hl, COLON, mh, ml, COLON, sh, sl)     when (frac /= 0) $ do@@ -138,4 +182,3 @@ {-# INLINE twoDigits #-} twoDigits a = (i2wDec hi, i2wDec lo)   where (hi,lo) = a `quotRem` 10-

@@ -40,7 +40,6 @@ import           Data.Foldable             (foldlM) import           Data.Hashable             (Hashable (..)) import qualified Data.List                 as List-import           Data.Primitive.PrimArray import           Data.Word import           Foreign.C.String import           GHC.CString@@ -61,7 +60,6 @@ import           System.IO.Unsafe          (unsafeDupablePerformIO) import           Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) import           Text.Read                 (Read (..))-import           Z.Data.Array import qualified Z.Data.Builder            as B import           Z.Data.JSON.Base          ((.!), (.:), (.=)) import qualified Z.Data.JSON.Base          as JSON@@ -103,7 +101,7 @@  -- | Construct a 'CBytes' from arbitrary array, result will be trimmed down to first @\\NUL@ byte if there's any. fromPrimArray :: PrimArray Word8 -> CBytes-{-# INLINE fromPrimArray #-}+{-# INLINABLE fromPrimArray #-} fromPrimArray arr = runST (do     let l = case V.elemIndex 0 arr of             Just i -> i@@ -130,7 +128,7 @@     :: PrimMonad m     => MutablePrimArray (PrimState m) Word8     -> m CBytes-{-# INLINE fromMutablePrimArray #-}+{-# INLINABLE fromMutablePrimArray #-} fromMutablePrimArray marr = do     let l = sizeofMutablePrimArray marr     arr <- unsafeFreezePrimArray marr@@ -213,6 +211,7 @@         let l = sizeofPrimArray pa         copyPrimArray (MutablePrimArray mba# :: MutablePrimArray RealWorld Word8) i pa 0 l +-- | Index a 'CBytes' until a \\NUL terminator(or to the end of the array if there's none). indexBACBytes :: BA# Word8 -> Int -> CBytes {-# INLINE indexBACBytes #-} indexBACBytes ba# i = runST (do@@ -257,7 +256,7 @@  -- | Concatenate two 'CBytes'. append :: CBytes -> CBytes -> CBytes-{-# INLINABLE append #-}+{-# INLINE append #-} append strA@(CBytes pa) strB@(CBytes pb)     | lenA == 0 = strB     | lenB == 0 = strA@@ -461,12 +460,12 @@  -- | /O(1)/, convert to 'V.Bytes', which can be processed by vector combinators. toBytes :: CBytes -> V.Bytes-{-# INLINABLE toBytes #-}+{-# INLINE toBytes #-} toBytes (CBytes arr) = V.PrimVector arr 0 (sizeofPrimArray arr - 1)  -- | /O(1)/, convert to 'V.Bytes' with its NULL terminator. toBytes' :: CBytes -> V.Bytes-{-# INLINABLE toBytes' #-}+{-# INLINE toBytes' #-} toBytes' (CBytes arr) = V.PrimVector arr 0 (sizeofPrimArray arr)  -- | /O(n)/, convert from 'V.Bytes'@@ -492,21 +491,21 @@ -- -- Throw 'T.InvalidUTF8Exception' in case of invalid codepoint. toText :: HasCallStack => CBytes -> T.Text-{-# INLINABLE toText #-}+{-# INLINE toText #-} toText = T.validate . toBytes  -- | /O(n)/, convert to 'T.Text' using UTF8 encoding assumption. -- -- Return 'Nothing' in case of invalid codepoint. toTextMaybe :: CBytes -> Maybe T.Text-{-# INLINABLE toTextMaybe #-}+{-# INLINE toTextMaybe #-} toTextMaybe = T.validateMaybe . toBytes  -- | /O(n)/, convert from 'T.Text', -- -- Result will be trimmed down to first @\\NUL@ byte if there's any. fromText :: T.Text -> CBytes-{-# INLINABLE fromText #-}+{-# INLINE fromText #-} fromText = fromBytes . T.getUTF8Bytes  -- | Write 'CBytes' \'s byte sequence to buffer.@@ -514,19 +513,19 @@ -- This function is different from 'T.Print' instance in that it directly write byte sequence without -- checking if it's UTF8 encoded. toBuilder :: CBytes -> B.Builder ()-{-# INLINABLE toBuilder #-}+{-# INLINE toBuilder #-} toBuilder = B.bytes . toBytes  -- | Write 'CBytes' \'s byte sequence to buffer, with its NULL terminator. -- toBuilder' :: CBytes -> B.Builder ()-{-# INLINABLE toBuilder' #-}+{-# INLINE toBuilder' #-} toBuilder' = B.bytes . toBytes'  -- | Build a 'CBytes' with builder, will automatically be trimmed down to first @\\NUL@ byte if there's any, -- or append with one if there's none. buildCBytes :: B.Builder a -> CBytes-{-# INLINABLE buildCBytes #-}+{-# INLINE buildCBytes #-} buildCBytes b = fromBytes (B.build (b >> B.word8 0))  --------------------------------------------------------------------------------

@@ -206,7 +206,7 @@ --------------------------------------------------------------------------------  symbCase :: Char -> String -> T.Text-{-# INLINE symbCase #-}+{-# INLINABLE symbCase #-} symbCase sym =  T.pack . go . applyFirst toLower   where     go []                       = []

@@ -200,7 +200,7 @@              -> T.Text     -- ^ The JSON value type you expecting to meet.              -> Value      -- ^ The actual value encountered.              -> Converter a-{-# INLINE typeMismatch #-}+{-# INLINABLE typeMismatch #-} typeMismatch name expected v =     fail' $ T.concat ["converting ", name, " failed, expected ", expected, ", encountered ", actual]   where@@ -324,7 +324,7 @@ withEmbeddedJSON :: T.Text                  -- ^ data type name                  -> (Value -> Converter a)     -- ^ a inner converter which will get the converted 'Value'.                  -> Value -> Converter a       -- a converter take a JSON String-{-# INLINE withEmbeddedJSON #-}+{-# INLINABLE withEmbeddedJSON #-} withEmbeddedJSON _ innerConverter (String txt) = Converter (\ kf k ->         case decode' (T.getUTF8Bytes txt) of             Right v -> runConverter (innerConverter v) (\ paths msg -> kf (Embedded:paths) msg) k@@ -441,6 +441,7 @@  -- | @Settings T.pack T.pack False@ defaultSettings :: Settings+{-# INLINE defaultSettings #-} defaultSettings = Settings T.pack T.pack False  --------------------------------------------------------------------------------

@@ -37,12 +37,12 @@ -- -- Don't use chars which need escaped in label. kv :: T.Text -> B.Builder () -> B.Builder ()-{-# INLINE kv #-}+{-# INLINABLE kv #-} l `kv` b = B.quotes (B.text l) >> B.colon >> b  -- | Use @:@ as separator to connect a label(escape the label and add quotes) with field builders. kv' :: T.Text -> B.Builder () -> B.Builder ()-{-# INLINE kv' #-}+{-# INLINABLE kv' #-} l `kv'` b = string l >> B.colon >> b  -- | Encode a 'Value', you can use this function with 'toValue' to get 'encodeJSON' with a small overhead.@@ -57,19 +57,19 @@ value _ = "null"  array :: V.Vector Value -> B.Builder ()-{-# INLINE array #-}+{-# INLINABLE array #-} array = B.square . B.intercalateVec B.comma value  array' :: (a -> B.Builder ()) -> V.Vector a -> B.Builder ()-{-# INLINE array' #-}+{-# INLINABLE array' #-} array' f = B.square . B.intercalateVec B.comma f  object :: V.Vector (T.Text, Value) -> B.Builder ()-{-# INLINE object #-}+{-# INLINABLE object #-} object = B.curly . B.intercalateVec B.comma (\ (k, v) -> k `kv'` value v)  object' :: (a -> B.Builder ()) -> V.Vector (T.Text, a) -> B.Builder ()-{-# INLINE object' #-}+{-# INLINABLE object' #-} object' f = B.curly . B.intercalateVec B.comma (\ (k, v) -> k `kv'` f v)  -- | Escape text into JSON string and add double quotes, escaping rules:@@ -87,7 +87,7 @@ -- @ -- string :: T.Text -> B.Builder ()-{-# INLINE string #-}+{-# INLINABLE string #-} string = T.escapeTextJSON  --------------------------------------------------------------------------------@@ -132,6 +132,7 @@ -- @ -- prettyValue :: Value -> B.Builder ()+{-# INLINABLE prettyValue #-} prettyValue = prettyValue' 4 0  @@ -149,7 +150,7 @@ prettyValue' _ !ind _            = B.word8N ind SPACE >> "null"  arrayPretty :: Int -> Int -> V.Vector Value -> B.Builder ()-{-# INLINE arrayPretty #-}+{-# INLINABLE arrayPretty #-} arrayPretty idpl ind vs     | V.null vs = B.word8N ind SPACE >> B.square (return ())     | otherwise = do@@ -166,7 +167,7 @@     ind' = ind + idpl  objectPretty :: Int -> Int -> V.Vector (T.Text, Value) -> B.Builder ()-{-# INLINE objectPretty #-}+{-# INLINABLE objectPretty #-} objectPretty idpl ind kvs     | V.null kvs = B.word8N ind SPACE >> B.curly (return ())     | otherwise = do

@@ -47,6 +47,7 @@     show = T.toString  instance T.Print ConvertError where+    {-# INLINABLE toUTF8BuilderP #-}     toUTF8BuilderP _ (ConvertError [] msg) = T.toUTF8Builder msg     toUTF8BuilderP _ (ConvertError paths msg) = do         mapM_ renderPath (reverse paths)

@@ -154,7 +154,7 @@ -- carriage pure, and tab. skipSpaces :: P.Parser () {-# INLINE skipSpaces #-}-skipSpaces = P.skipWhile (\ w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09)+skipSpaces = P.skipWhile (\ w -> w <= 0x20 && (w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09))  -- | JSON 'Value' parser. value :: P.Parser Value@@ -174,12 +174,12 @@  -- | parse json array with leading SQUARE_LEFT. array :: P.Parser (V.Vector Value)-{-# INLINE array #-}+{-# INLINABLE array #-} array = P.word8 SQUARE_LEFT *> array_  -- | parse json array without leading SQUARE_LEFT. array_ :: P.Parser (V.Vector Value)-{-# INLINABLE array_ #-}+{-# INLINE array_ #-} array_ = do     skipSpaces     w <- P.peek@@ -199,12 +199,12 @@  -- | parse json array with leading 'CURLY_LEFT'. object :: P.Parser (V.Vector (T.Text, Value))-{-# INLINE object #-}+{-# INLINABLE object #-} object = P.word8 CURLY_LEFT *> object_  -- | parse json object without leading 'CURLY_LEFT'. object_ :: P.Parser (V.Vector (T.Text, Value))-{-# INLINABLE object_ #-}+{-# INLINE object_ #-} object_ = do     skipSpaces     w <- P.peek@@ -228,7 +228,7 @@ --------------------------------------------------------------------------------  string :: P.Parser T.Text-{-# INLINE string #-}+{-# INLINABLE string #-} string = P.word8 DOUBLE_QUOTE *> string_  string_ :: P.Parser T.Text@@ -268,20 +268,20 @@  -- | Convert IEEE float to scientific notition. floatToScientific :: Float -> Scientific-{-# INLINE floatToScientific #-}+{-# INLINABLE floatToScientific #-} floatToScientific rf | rf < 0    = -(fromFloatingDigits (B.grisu3_sp (-rf)))                      | rf == 0   = 0                      | otherwise = fromFloatingDigits (B.grisu3_sp rf)  -- | Convert IEEE double to scientific notition. doubleToScientific :: Double -> Scientific-{-# INLINE doubleToScientific #-}+{-# INLINABLE doubleToScientific #-} doubleToScientific rf | rf < 0    = -(fromFloatingDigits (B.grisu3 (-rf)))                       | rf == 0   = 0                       | otherwise = fromFloatingDigits (B.grisu3 rf)  fromFloatingDigits :: ([Int], Int) -> Scientific-{-# INLINE fromFloatingDigits #-}+{-# INLINABLE fromFloatingDigits #-} fromFloatingDigits (digits, e) = go digits 0 0   where     -- There's no way a float or double has more digits a 'Int64' can't handle

@@ -30,7 +30,7 @@   , Parser   , (<?>)     -- * Running a parser-  , parse, parse', parseChunk, ParseChunks, parseChunks, finishParsing+  , parse, parse', parseChunk, parseChunkList, ParseChunks, parseChunks, finishParsing   , runAndKeepTrack, match     -- * Basic parsers   , ensureN, endOfInput, atEnd, currentChunk@@ -41,7 +41,7 @@   , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith   , anyWord8, word8, char8, anyChar8, anyCharUTF8, charUTF8, char7, anyChar7   , skipWord8, endOfLine, skip, skipWhile, skipSpaces-  , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI+  , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, takeUTF8, bytes, bytesCI   , text     -- * Numeric parsers     -- ** Decimal

@@ -19,7 +19,7 @@   , Parser(..)   , (<?>)     -- * Running a parser-  , parse, parse', parseChunk, ParseChunks, parseChunks, finishParsing+  , parse, parse', parseChunk, parseChunkList, ParseChunks, parseChunks, finishParsing   , runAndKeepTrack, match     -- * Basic parsers   , ensureN, endOfInput, currentChunk, atEnd@@ -30,7 +30,7 @@   , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith   , anyWord8, word8, char8, anyChar8, anyCharUTF8, charUTF8, char7, anyChar7   , skipWord8, endOfLine, skip, skipWhile, skipSpaces-  , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI+  , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, takeUTF8,  bytes, bytesCI   , text     -- * Error reporting   , fail', failWithInput, unsafeLiftIO@@ -44,6 +44,7 @@   ) where  import           Control.Applicative+import           Control.Exception                  (assert) import           Control.Monad import           Control.Monad.Primitive import qualified Control.Monad.Fail                 as Fail@@ -117,21 +118,29 @@  -- It seems eta-expand all params to ensure parsers are saturated is helpful instance Functor Parser where-    fmap f (Parser pa) = Parser (\ kf k s inp -> pa kf (\ s' -> k s' . f) s inp)+    fmap = fmapParser     {-# INLINE fmap #-}     a <$ Parser pb = Parser (\ kf k s inp -> pb kf (\ s' _ -> k s' a) s inp)     {-# INLINE (<$) #-} +fmapParser :: (a -> b) -> Parser a -> Parser b+{-# INLINE fmapParser #-}+fmapParser f (Parser pa) = Parser (\ kf k s inp -> pa kf (\ s' -> k s' . f) s inp)+ instance Applicative Parser where     pure x = Parser (\ _ k s inp -> k s x inp)     {-# INLINE pure #-}-    Parser pf <*> Parser pa = Parser (\ kf k s inp -> pf kf (\ s' f -> pa kf (\ s'' -> k s'' . f) s') s inp)+    (<*>) = apParser     {-# INLINE (<*>) #-}     Parser pa *> Parser pb = Parser (\ kf k s inp -> pa kf (\ s' _ -> pb kf k s') s inp)     {-# INLINE (*>) #-}     Parser pa <* Parser pb = Parser (\ kf k s inp -> pa kf (\ s' x -> pb kf (\ s'' _ -> k s'' x) s') s inp)     {-# INLINE (<*) #-} +apParser :: Parser (a -> b) -> Parser a -> Parser b+{-# INLINE apParser #-}+apParser (Parser pf) (Parser pa) = Parser (\ kf k s inp -> pf kf (\ s' f -> pa kf (\ s'' -> k s'' . f) s') s inp)+ instance Monad Parser where     return = pure     {-# INLINE return #-}@@ -175,11 +184,10 @@     empty = fail' "Z.Data.Parser.Base(Alternative).empty"     {-# INLINE empty #-}     f <|> g = do-        (r, bss) <- runAndKeepTrack f+        (r, consumed) <- runAndKeepTrack f         case r of             Success x inp   -> Parser (\ _ k s _ -> k s x inp)-            Failure _ _     -> let !bs = V.concat (reverse bss)-                               in Parser (\ kf k s _ -> runParser g kf k s bs)+            Failure _ _     -> Parser (\ kf k s _ -> runParser g kf k s consumed)             _               -> error "Z.Data.Parser.Base: impossible"     {-# INLINE (<|>) #-} @@ -195,16 +203,34 @@  -- | Parse the complete input, without resupplying parse' :: Parser a -> V.Bytes -> Either ParseError a-{-# INLINE parse' #-}-parse' (Parser p) inp = snd $ finishParsing (runRW# (\ s ->-        unsafeCoerce# (p Failure (\ _ r -> Success r) (unsafeCoerce# s) inp)))+{-# INLINABLE parse' #-}+parse' p = snd . parse p  -- | Parse the complete input, without resupplying, return the rest bytes parse :: Parser a -> V.Bytes -> (V.Bytes, Either ParseError a) {-# INLINE parse #-}-parse (Parser p) inp = finishParsing (runRW# ( \ s ->-    unsafeCoerce# (p Failure (\ _ r -> Success r) (unsafeCoerce# s) inp)))+parse (Parser p) = \ inp ->+    case (runRW# ( \ s -> unsafeCoerce# (p Failure (\ _ r -> Success r) (unsafeCoerce# s) inp))) of+        Success a rest    -> (rest, Right a)+        Failure errs rest -> (rest, Left errs)+        Partial f         -> finishParsing (f V.empty) +-- | Parse the complete input list, without resupplying, return the rest bytes list.+--+-- Parsers in "Z.Data.Parser" will take 'V.empty' as EOF, so please make sure there are no 'V.empty's+-- mixed into the chunk list.+parseChunkList :: Parser a -> [V.Bytes] -> ([V.Bytes], Either ParseError a)+{-# INLINABLE parseChunkList #-}+parseChunkList p (inp:inps) = go (parseChunk p inp) inps+    where+        go r is = case r of+            Partial f -> case is of+                (i:is') -> go (f i) is'+                _ -> let (rest, r') = finishParsing r+                     in (if V.null rest then [] else [rest], r')+            Success a rest    -> (if V.null rest then is else rest:is, Right a)+            Failure errs rest -> (if V.null rest then is else rest:is, Left errs)+ -- | Parse an input chunk parseChunk :: Parser a -> V.Bytes -> Result ParseError a {-# INLINE parseChunk #-}@@ -227,7 +253,7 @@ -- that can supply more input if needed. -- parseChunks :: Monad m => (V.Bytes -> Result e a) -> ParseChunks m e a-{-# INLINABLE parseChunks #-}+{-# INLINE parseChunks #-} parseChunks pc m inp = go (pc inp)   where     go r = case r of@@ -244,13 +270,13 @@ -- Once it's finished, return the final result (always 'Success' or 'Failure') and -- all consumed chunks. ---runAndKeepTrack :: Parser a -> Parser (Result ParseError a, [V.Bytes])+runAndKeepTrack :: Parser a -> Parser (Result ParseError a, V.Bytes) {-# INLINE runAndKeepTrack #-} runAndKeepTrack (Parser pa) = Parser $ \ _ k0 st0 inp ->     let go !acc r k (st :: State# ParserState) = case r of             Partial k'      -> Partial (\ inp' -> go (inp':acc) (k' inp') k st)-            Success _ inp' -> k st (r, reverse acc) inp'-            Failure _ inp' -> k st (r, reverse acc) inp'+            Success _ inp' -> let consumed = V.concatR acc in consumed `seq` k st (r, consumed) inp'+            Failure _ inp' -> let consumed = V.concatR acc in consumed `seq` k st (r, consumed) inp'         r0 = runRW# (\ s ->                 unsafeCoerce# (pa Failure (\ _ r -> Success r) (unsafeCoerce# s) inp))     in go [inp] r0 k0 st0@@ -260,11 +286,10 @@ match :: Parser a -> Parser (V.Bytes, a) {-# INLINE match #-} match p = do-    (r, bss) <- runAndKeepTrack p+    (r, consumed) <- runAndKeepTrack p     Parser (\ _ k s _ ->         case r of-            Success r' inp'  -> let !consumed = V.dropR (V.length inp') (V.concat (reverse bss))-                                in k s (consumed , r') inp'+            Success r' inp'  -> k s (consumed , r') inp'             Failure err inp' -> Failure err inp'             Partial _        -> error "Z.Data.Parser.Base.match: impossible") @@ -279,24 +304,61 @@     let l = V.length inp     if n0 <= l     then k s () inp-    else Partial (ensureNPartial err (n0-l) inp kf k s)+    else Partial (ensureNPartial (n0-l) inp kf k s)   where+    ensureNPartial :: forall r. Int -> V.PrimVector Word8 -> (ParseError -> ParseStep ParseError r)+                   -> (State# ParserState -> () -> ParseStep ParseError r)+                   -> State# ParserState -> ParseStep ParseError r+    ensureNPartial !l0 inp0 kf k s0 =+        let go acc !l s = \ inp -> do+                let l' = V.length inp+                if l' == 0+                then kf [err] (V.concatR (inp:acc))+                else do+                    if l <= l'+                    then let !inp' = V.concatR (inp:acc) in k s () inp'+                    else Partial (go (inp:acc) (l - l') s)+        in go [inp0] l0 s0 -ensureNPartial :: forall r. T.Text -> Int -> V.PrimVector Word8 -> (ParseError -> ParseStep ParseError r)-               -> (State# ParserState -> () -> ParseStep ParseError r)-               -> State# ParserState -> ParseStep ParseError r-{-# INLINE ensureNPartial #-}-ensureNPartial err !l0 inp0 kf k s0 =-    let go acc !l s = \ inp -> do-            let l' = V.length inp-            if l' == 0-            then kf [err] (V.concat (reverse (inp:acc)))-            else do-                if l <= l'-                then let !inp' = V.concat (reverse (inp:acc)) in k s () inp'-                else Partial (go (inp:acc) (l - l') s)-    in go [inp0] l0 s0+-- | Ensure that there are at least @n@ bytes available. If not, the+-- computation will escape with 'Partial'.+--+-- Since this parser is used in many other parsers, an extra error param is provide+-- to attach custom error info.+readN :: forall a. Int -> T.Text -> (V.Bytes -> a) -> Parser a+{-# INLINE readN #-}+readN n0 err f = Parser $ \ kf k s inp -> do+    let l = V.length inp+    if n0 <= l+    then let !r = f inp+             !inp' = V.unsafeDrop n0 inp+             in k s r inp'+    else Partial (readNPartial (n0-l) inp kf k s)+  where+    readNPartial :: forall r. Int -> V.PrimVector Word8 -> (ParseError -> ParseStep ParseError r)+                   -> (State# ParserState -> a -> ParseStep ParseError r)+                   -> State# ParserState -> ParseStep ParseError r+    readNPartial !l0 inp0 kf k s0 =+        let go acc !l s = \ inp -> do+                let l' = V.length inp+                if l' == 0+                then kf [err] (V.concatR (inp:acc))+                else do+                    if l <= l'+                    then let !inp' = V.concatR (inp:acc)+                             !r  = f inp'+                             !inp'' = V.unsafeDrop n0 inp'+                         in k s r inp''+                    else Partial (go (inp:acc) (l - l') s)+        in go [inp0] l0 s0 +{- These rules are bascially what inliner do so no need to mess up with them+{-# RULES "readN/fmap"+    forall n f g e. fmapParser f (readN n e g)  = readN n e (f . g) #-}+{-# RULES "readN/merge"+    forall n1 n2 e1 e2 f1 f2. apParser (readN n1 e1 f1) (readN n2 e2 f2) = readN (n1 + n2) (T.concat [e1, ", ", e2]) (\ inp -> f1 inp $! f2 (V.unsafeDrop n1 inp)) #-}+-}+ -- | Get current input chunk, draw new chunk if neccessary. 'V.null' means EOF. -- -- Note this is different from 'takeRemaining', 'currentChunk' only return what's@@ -332,23 +394,8 @@ -- | Decode a primitive type in host byte order. decodePrim :: forall a. (Unaligned a) => Parser a {-# INLINE decodePrim #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Word   #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Word64 #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Word32 #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Word16 #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Word8  #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Int   #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Int64 #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Int32 #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Int16 #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Int8  #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Double #-}-{-# SPECIALIZE INLINE decodePrim :: Parser Float #-} decodePrim = do-    ensureN n "Z.Data.Parser.Base.decodePrim: not enough bytes"-    Parser (\ _ k s (V.PrimVector ba i len) ->-        let !r = indexPrimWord8ArrayAs ba i-        in k s r (V.PrimVector ba (i+n) (len-n)))+    readN n "Z.Data.Parser.Base.decodePrim: not enough bytes" (\ (V.PrimVector ba i _) -> indexPrimWord8ArrayAs ba i)   where     n = getUnalignedSize (unalignedSize @a) @@ -372,21 +419,8 @@ -- | Decode a primitive type in little endian. decodePrimLE :: forall a. (Unaligned (LE a)) => Parser a {-# INLINE decodePrimLE #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Word   #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Word64 #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Word32 #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Word16 #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Int   #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Int64 #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Int32 #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Int16 #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Double #-}-{-# SPECIALIZE INLINE decodePrimLE :: Parser Float #-} decodePrimLE = do-    ensureN n "Z.Data.Parser.Base.decodePrimLE: not enough bytes"-    Parser (\ _ k s (V.PrimVector ba i len) ->-        let !r = indexPrimWord8ArrayAs ba i-        in k s (getLE r) (V.PrimVector ba (i+n) (len-n)))+    readN n "Z.Data.Parser.Base.decodePrimLE: not enough bytes" (\ (V.PrimVector ba i _) -> getLE (indexPrimWord8ArrayAs ba i))   where     n = getUnalignedSize (unalignedSize @(LE a)) @@ -408,21 +442,8 @@ -- | Decode a primitive type in big endian. decodePrimBE :: forall a. (Unaligned (BE a)) => Parser a {-# INLINE decodePrimBE #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Word   #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Word64 #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Word32 #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Word16 #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Int   #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Int64 #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Int32 #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Int16 #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Double #-}-{-# SPECIALIZE INLINE decodePrimBE :: Parser Float #-} decodePrimBE = do-    ensureN n "Z.Data.Parser.Base.decodePrimBE: not enough bytes"-    Parser (\ _ k s (V.PrimVector ba i len) ->-        let !r = indexPrimWord8ArrayAs ba i-        in k s (getBE r) (V.PrimVector ba (i+n) (len-n)))+    readN n "Z.Data.Parser.Base.decodePrimBE: not enough bytes" (\ (V.PrimVector ba i _) -> getBE (indexPrimWord8ArrayAs ba i))   where     n = getUnalignedSize (unalignedSize @(BE a)) @@ -473,6 +494,9 @@ -- the predicate on each chunk of the input until one chunk got splited to -- @Right (V.Bytes, V.Bytes)@ or the input ends. --+-- Note the fields of result triple will not be forced by 'scanChunks', you may need to add `seq` or strict annotation to+-- avoid thunks and unintentional references to buffer.+-- scanChunks :: forall s. s -> (s -> V.Bytes -> Either s (V.Bytes, V.Bytes, s)) -> Parser (V.Bytes, s) {-# INLINE scanChunks #-} scanChunks s0 consume = Parser (\ _ k st inp ->@@ -481,19 +505,19 @@         Left s' -> Partial (scanChunksPartial s' k st inp))   where     -- we want to inline consume if possible-    {-# INLINABLE scanChunksPartial #-}+    {-# INLINE scanChunksPartial #-}     scanChunksPartial :: forall r. s -> (State# ParserState -> (V.PrimVector Word8, s) -> ParseStep ParseError r)                       -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r     scanChunksPartial s0' k st0 inp0 =         let go s acc st = \ inp ->                 if V.null inp-                then k st (V.concat (reverse acc), s) inp+                then k st (V.concatR acc, s) inp                 else case consume s inp of                         Left s' -> do                             let acc' = inp : acc                             Partial (go s' acc' st)                         Right (want,rest,s') ->-                            let !r = V.concat (reverse (want:acc)) in k st (r, s') rest+                            let !r = V.concatR (want:acc) in k st (r, s') rest         in go s0' [inp0] st0  --------------------------------------------------------------------------------@@ -620,7 +644,7 @@ -- -- Don't use this method as UTF8 decoder, it's slower than 'T.validate'. anyCharUTF8 :: Parser Char-{-# INLINABLE anyCharUTF8 #-}+{-# INLINE anyCharUTF8 #-} anyCharUTF8 = do     r <- Parser $ \ kf k st inp@(V.PrimVector arr s l) -> do         if l > 0@@ -663,27 +687,25 @@ -- skip :: Int -> Parser () {-# INLINE skip #-}-skip n =+skip n = assert (n > 0) $     Parser (\ kf k s inp ->         let l = V.length inp-            !n' = max n 0-        in if l >= n'-            then k s () $! V.unsafeDrop n' inp-            else Partial (skipPartial (n'-l) kf k s))--skipPartial :: Int -> (ParseError -> ParseStep ParseError r)-            -> (State# ParserState -> () -> ParseStep ParseError r)-            -> State# ParserState -> ParseStep ParseError r-{-# INLINABLE skipPartial #-}-skipPartial n kf k s0 =-    let go !n' s = \ inp ->-            let l = V.length inp-            in if l >= n'-                then k s () $! V.unsafeDrop n' inp-                else if l == 0-                    then kf ["Z.Data.Parser.Base.skip: not enough bytes"] inp-                    else Partial (go (n'-l) s)-    in go n s0+        in if l >= n+            then k s () $! V.unsafeDrop n inp+            else Partial (skipPartial (n-l) kf k s))+  where+    skipPartial :: Int -> (ParseError -> ParseStep ParseError r)+                -> (State# ParserState -> () -> ParseStep ParseError r)+                -> State# ParserState -> ParseStep ParseError r+    skipPartial n0 kf k s0 =+        let go !n' s = \ inp ->+                let l = V.length inp+                in if l >= n'+                    then k s () $! V.unsafeDrop n' inp+                    else if l == 0+                        then kf ["Z.Data.Parser.Base.skip: not enough bytes"] inp+                        else Partial (go (n'-l) s)+        in go n0 s0  -- | Skip a byte. --@@ -704,13 +726,11 @@ {-# INLINE skipWhile #-} skipWhile p =     Parser (\ _ k s inp ->-        let rest = V.dropWhile p inp+        let !rest = V.dropWhile p inp         in if V.null rest             then Partial (skipWhilePartial k s)             else k s () rest)   where-    -- we want to inline p if possible-    {-# INLINABLE skipWhilePartial #-}     skipWhilePartial :: forall r. (State# ParserState -> () -> ParseStep ParseError r)                      -> State# ParserState -> ParseStep ParseError r     skipWhilePartial k s0 =@@ -728,16 +748,10 @@ {-# INLINE skipSpaces #-} skipSpaces = skipWhile isSpace +-- | Take N bytes. take :: Int -> Parser V.Bytes {-# INLINE take #-}-take n = do-    -- we use unsafe slice, guard negative n here-    ensureN n' "Z.Data.Parser.Base.take: not enough bytes"-    Parser (\ _ k s inp ->-        let !r = V.unsafeTake n' inp-            !inp' = V.unsafeDrop n' inp-        in k s r inp')-  where !n' = max 0 n+take n = assert (n > 0) $ readN n "Z.Data.Parser.Base.take: not enough bytes" (V.unsafeTake n)  -- | Consume input as long as the predicate returns 'False' or reach the end of input, -- and return the consumed input.@@ -745,24 +759,23 @@ takeTill :: (Word8 -> Bool) -> Parser V.Bytes {-# INLINE takeTill #-} takeTill p = Parser (\ _ k s inp ->-    let (want, rest) = V.break p inp+    let (!want, !rest) = V.break p inp     in if V.null rest         then Partial (takeTillPartial k s want)         else k s want rest)   where-    {-# INLINABLE takeTillPartial #-}     takeTillPartial :: forall r. (State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r)                     -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r     takeTillPartial k s0 want =         let go acc s = \ inp ->                 if V.null inp-                then let !r = V.concat (reverse acc) in k s r inp+                then let !r = V.concatR acc in k s r inp                 else-                    let (want', rest) = V.break p inp+                    let (!want', !rest) = V.break p inp                         acc' = want' : acc                     in if V.null rest                         then Partial (go acc' s)-                        else let !r = V.concat (reverse acc') in k s r rest+                        else let !r = V.concatR acc' in k s r rest         in go [want] s0  -- | Consume input as long as the predicate returns 'True' or reach the end of input,@@ -771,25 +784,23 @@ takeWhile :: (Word8 -> Bool) -> Parser V.Bytes {-# INLINE takeWhile #-} takeWhile p = Parser (\ _ k s inp ->-    let (want, rest) = V.span p inp+    let (!want, !rest) = V.span p inp     in if V.null rest         then Partial (takeWhilePartial k s want)         else k s want rest)   where-    -- we want to inline p if possible-    {-# INLINABLE takeWhilePartial #-}     takeWhilePartial :: forall r. (State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r)                      -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r     takeWhilePartial k s0 want =         let go acc s = \ inp ->                 if V.null inp-                then let !r = V.concat (reverse acc) in k s r inp+                then let !r = V.concatR acc in k s r inp                 else-                    let (want', rest) = V.span p inp+                    let (!want', !rest) = V.span p inp                         acc' = want' : acc                     in if V.null rest                         then Partial (go acc' s)-                        else let !r = V.concat (reverse acc') in k s r rest+                        else let !r = V.concatR acc' in k s r rest         in go [want] s0  -- | Similar to 'takeWhile', but requires the predicate to succeed on at least one byte@@ -810,16 +821,23 @@ {-# INLINE takeRemaining #-} takeRemaining = Parser (\ _ k s inp -> Partial (takeRemainingPartial k s inp))   where-    {-# INLINABLE takeRemainingPartial #-}     takeRemainingPartial :: forall r. (State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r)                          -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r     takeRemainingPartial k s0 want =         let go acc s = \ inp ->                 if V.null inp-                then let !r = V.concat (reverse acc) in k s r inp-                else let acc' = inp : acc in Partial (go acc' s)+                then let !r = V.concatR acc in k s r inp+                else Partial (go (inp:acc) s)         in go [want] s0 +-- | Take N bytes and validate as UTF8, failed if not UTF8 encoded.+takeUTF8 :: Int -> Parser T.Text+{-# INLINE takeUTF8 #-}+takeUTF8 n = do+    bs <- take n+    case T.validateMaybe bs of Just t -> pure t+                               _ -> fail' $ "Z.Data.Parser.Base.takeUTF8: illegal UTF8 bytes: " <> T.toText bs+ -- | Similar to 'take', but requires the predicate to succeed on next N bytes -- of input, and take N bytes(no matter if N+1 byte satisfy predicate or not). --@@ -870,7 +888,7 @@              "Z.Data.Parser.Base.bytesCI: mismatch bytes, expected "             , T.toText bs             , "(case insensitive), meet "-            , T.toText (V.take n inp)+            , T.toText (V.unsafeTake n inp)             ] ] inp)    where

@@ -70,7 +70,17 @@ -- >>> parse' hex "7FF" == Left ["Z.Data.Parser.Numeric.hex","hex numeric number overflow"] -- hex :: forall a.(Integral a, FiniteBits a) => Parser a-{-# INLINE hex #-}+{-# INLINABLE hex #-}+{-# SPECIALIZE INLINE hex :: Parser Int #-}+{-# SPECIALIZE INLINE hex :: Parser Int8 #-}+{-# SPECIALIZE INLINE hex :: Parser Int16 #-}+{-# SPECIALIZE INLINE hex :: Parser Int32 #-}+{-# SPECIALIZE INLINE hex :: Parser Int64 #-}+{-# SPECIALIZE INLINE hex :: Parser Word #-}+{-# SPECIALIZE INLINE hex :: Parser Word8 #-}+{-# SPECIALIZE INLINE hex :: Parser Word16 #-}+{-# SPECIALIZE INLINE hex :: Parser Word32 #-}+{-# SPECIALIZE INLINE hex :: Parser Word64 #-} hex = "Z.Data.Parser.Numeric.hex" <?> do     bs <- P.takeWhile1 isHexDigit     if V.length bs <= finiteBitSize (undefined :: a) `unsafeShiftR` 2@@ -84,7 +94,17 @@ -- >>> parse' hex "7Ft" == Right (127 :: Int8) -- >>> parse' hex "7FF" == Right (127 :: Int8) hex' :: forall a.(Integral a, FiniteBits a) => Parser a-{-# INLINE hex' #-}+{-# INLINABLE hex' #-}+{-# SPECIALIZE INLINE hex' :: Parser Int #-}+{-# SPECIALIZE INLINE hex' :: Parser Int8 #-}+{-# SPECIALIZE INLINE hex' :: Parser Int16 #-}+{-# SPECIALIZE INLINE hex' :: Parser Int32 #-}+{-# SPECIALIZE INLINE hex' :: Parser Int64 #-}+{-# SPECIALIZE INLINE hex' :: Parser Word #-}+{-# SPECIALIZE INLINE hex' :: Parser Word8 #-}+{-# SPECIALIZE INLINE hex' :: Parser Word16 #-}+{-# SPECIALIZE INLINE hex' :: Parser Word32 #-}+{-# SPECIALIZE INLINE hex' :: Parser Word64 #-} hex' = "Z.Data.Parser.Numeric.hex'" <?> do     hexLoop 0 <$>         P.takeN isHexDigit (finiteBitSize (undefined :: a) `unsafeShiftR` 2)@@ -97,7 +117,17 @@ -- >>> parse' hex "7Ft" == Right (127 :: Int8) -- >>> parse' hex "7FF" == Right (-1 :: Int8) hex_ :: (Integral a, Bits a) => Parser a-{-# INLINE hex_ #-}+{-# INLINABLE hex_ #-}+{-# SPECIALIZE INLINE hex_ :: Parser Int #-}+{-# SPECIALIZE INLINE hex_ :: Parser Int8 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Int16 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Int32 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Int64 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Word #-}+{-# SPECIALIZE INLINE hex_ :: Parser Word8 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Word16 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Word32 #-}+{-# SPECIALIZE INLINE hex_ :: Parser Word64 #-} hex_ = "Z.Data.Parser.Numeric.hex_" <?> hexLoop 0 <$> P.takeWhile1 isHexDigit  -- | decode hex digits sequence within an array.@@ -120,14 +150,34 @@  -- | Same with 'uint', but sliently cast in case of overflow. uint_ :: forall a. (Integral a, Bounded a) => Parser a-{-# INLINE uint_ #-}+{-# INLINABLE uint_ #-}+{-# SPECIALIZE INLINE uint_ :: Parser Int #-}+{-# SPECIALIZE INLINE uint_ :: Parser Int8 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Int16 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Int32 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Int64 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Word #-}+{-# SPECIALIZE INLINE uint_ :: Parser Word8 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Word16 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Word32 #-}+{-# SPECIALIZE INLINE uint_ :: Parser Word64 #-} uint_ = "Z.Data.Parser.Numeric.uint_" <?> decLoop 0 <$> P.takeWhile1 isDigit  -- | Parse and decode an unsigned decimal number. -- -- Will fail in case of overflow. uint :: forall a. (Integral a, Bounded a) => Parser a-{-# INLINE uint #-}+{-# INLINABLE uint #-}+{-# SPECIALIZE INLINE uint :: Parser Int #-}+{-# SPECIALIZE INLINE uint :: Parser Int8 #-}+{-# SPECIALIZE INLINE uint :: Parser Int16 #-}+{-# SPECIALIZE INLINE uint :: Parser Int32 #-}+{-# SPECIALIZE INLINE uint :: Parser Int64 #-}+{-# SPECIALIZE INLINE uint :: Parser Word #-}+{-# SPECIALIZE INLINE uint :: Parser Word8 #-}+{-# SPECIALIZE INLINE uint :: Parser Word16 #-}+{-# SPECIALIZE INLINE uint :: Parser Word32 #-}+{-# SPECIALIZE INLINE uint :: Parser Word64 #-} uint = "Z.Data.Parser.Numeric.uint" <?> do     bs <- P.takeWhile1 isDigit     if V.length bs <= WORD64_SAFE_DIGITS_LEN@@ -173,6 +223,7 @@ -- | Take a single decimal digit and return as 'Int'. -- digit :: Parser Int+{-# INLINE digit #-} digit = do     d <- P.satisfy isDigit     return $! w2iDec d@@ -182,7 +233,17 @@ -- -- This parser will fail if overflow happens. int :: forall a. (Integral a, Bounded a) => Parser a-{-# INLINE int #-}+{-# INLINABLE int #-}+{-# SPECIALIZE INLINE int :: Parser Int #-}+{-# SPECIALIZE INLINE int :: Parser Int8 #-}+{-# SPECIALIZE INLINE int :: Parser Int16 #-}+{-# SPECIALIZE INLINE int :: Parser Int32 #-}+{-# SPECIALIZE INLINE int :: Parser Int64 #-}+{-# SPECIALIZE INLINE int :: Parser Word #-}+{-# SPECIALIZE INLINE int :: Parser Word8 #-}+{-# SPECIALIZE INLINE int :: Parser Word16 #-}+{-# SPECIALIZE INLINE int :: Parser Word32 #-}+{-# SPECIALIZE INLINE int :: Parser Word64 #-} int = "Z.Data.Parser.Numeric.int" <?> do     w <- P.peek     if w == MINUS@@ -218,7 +279,17 @@  -- | Same with 'int', but sliently cast if overflow happens. int_ :: (Integral a, Bounded a) => Parser a-{-# INLINE int_ #-}+{-# INLINABLE int_ #-}+{-# SPECIALIZE INLINE int_ :: Parser Int #-}+{-# SPECIALIZE INLINE int_ :: Parser Int8 #-}+{-# SPECIALIZE INLINE int_ :: Parser Int16 #-}+{-# SPECIALIZE INLINE int_ :: Parser Int32 #-}+{-# SPECIALIZE INLINE int_ :: Parser Int64 #-}+{-# SPECIALIZE INLINE int_ :: Parser Word #-}+{-# SPECIALIZE INLINE int_ :: Parser Word8 #-}+{-# SPECIALIZE INLINE int_ :: Parser Word16 #-}+{-# SPECIALIZE INLINE int_ :: Parser Word32 #-}+{-# SPECIALIZE INLINE int_ :: Parser Word64 #-} int_ = "Z.Data.Parser.Numeric.int_" <?> do     w <- P.peek     if w == MINUS@@ -230,7 +301,7 @@ -- | Parser specifically optimized for 'Integer'. -- integer :: Parser Integer-{-# INLINE integer #-}+{-# INLINABLE integer #-} integer =  "Z.Data.Parser.Numeric.integer" <?> do     w <- P.peek     if w == MINUS@@ -253,7 +324,7 @@ -- instead. -- rational :: (Fractional a) => Parser a-{-# INLINE rational #-}+{-# INLINABLE rational #-} rational = "Z.Data.Parser.Numeric.rational" <?> scientificallyInternal realToFrac  -- | Parse a rational number and round to 'Double'.@@ -283,14 +354,14 @@ -- \"Infinity\". -- double :: Parser Double-{-# INLINE double #-}+{-# INLINABLE double #-} double = "Z.Data.Parser.Numeric.double" <?> scientificallyInternal sciToDouble  -- | Parse a rational number and round to 'Float'. -- -- Single precision version of 'double'. float :: Parser Float-{-# INLINE float #-}+{-# INLINABLE float #-} float = "Z.Data.Parser.Numeric.float" <?> scientificallyInternal Sci.toRealFloat  -- | Parse a scientific number.@@ -298,14 +369,14 @@ -- The syntax accepted by this parser is the same as for 'double'. -- scientific :: Parser Sci.Scientific-{-# INLINE scientific #-}+{-# INLINABLE scientific #-} scientific = "Z.Data.Parser.Numeric.scientific" <?> scientificallyInternal id  -- | Parse a scientific number and convert to result using a user supply function. -- -- The syntax accepted by this parser is the same as for 'double'. scientifically :: (Sci.Scientific -> a) -> Parser a-{-# INLINE scientifically #-}+{-# INLINABLE scientifically #-} scientifically h = "Z.Data.Parser.Numeric.scientifically" <?> scientificallyInternal h  -- | Strip message version.@@ -331,10 +402,10 @@                         f = decLoopIntegerFast fracPart                     in i * (expt 10 flen) + f         parseE base flen) <|> (parseE (decLoopIntegerFast intPart) 0)--    pure $! if sign /= MINUS then h sci else h (negate sci)+    -- intentionally lazy return here, we have done the grammar check, and h could potentially be very expensive, e.g. sciToDouble+    -- retained references are sign and sci, which are already in NF+    pure (if sign /= MINUS then h sci else h (negate sci))   where-    {-# INLINE parseE #-}     parseE c e =         (do _ <- P.satisfy (\w -> w ==  LETTER_e || w == LETTER_E)             e' <- int@@ -355,7 +426,7 @@ -- instead. -- rational' :: (Fractional a) => Parser a-{-# INLINE rational' #-}+{-# INLINABLE rational' #-} rational' = "Z.Data.Parser.Numeric.rational'" <?> scientificallyInternal' realToFrac  -- | More strict number parsing(rfc8259).@@ -388,14 +459,20 @@ -- \"Infinity\". -- reference: https://tools.ietf.org/html/rfc8259#section-6 double' :: Parser Double-{-# INLINE double' #-}+{-# INLINABLE double' #-} double' = "Z.Data.Parser.Numeric.double'" <?> scientificallyInternal' sciToDouble +#define FASTFLOAT_SMALLEST_POWER -325+#define FASTFLOAT_LARGEST_POWER 308+ -- | Faster scientific to double conversion using <https://github.com/lemire/fast_double_parser/>.+--+-- See @cbits/compute_float_64.c@. sciToDouble :: Sci.Scientific -> Double+{-# INLINABLE sciToDouble #-} sciToDouble sci = case c of #ifdef INTEGER_GMP-    (S# i#) -> unsafeDupablePerformIO $ do+    (S# i#) | (e >= FASTFLOAT_SMALLEST_POWER && e <= FASTFLOAT_LARGEST_POWER) -> unsafeDupablePerformIO $ do         let i = (I# i#)             s = if i >= 0 then 0 else 1             i' = fromIntegral $ if i >= 0 then i else (0-i)@@ -413,21 +490,21 @@ -- -- Single precision version of 'double''. float' :: Parser Float-{-# INLINE float' #-}+{-# INLINABLE float' #-} float' = "Z.Data.Parser.Numeric.float'" <?> scientificallyInternal' Sci.toRealFloat  -- | Parse a scientific number. -- -- The syntax accepted by this parser is the same as for 'double''. scientific' :: Parser Sci.Scientific-{-# INLINE scientific' #-}+{-# INLINABLE scientific' #-} scientific' = "Z.Data.Parser.Numeric.scientific'" <?> scientificallyInternal' id  -- | Parse a scientific number and convert to result using a user supply function. -- -- The syntax accepted by this parser is the same as for 'double''. scientifically' :: (Sci.Scientific -> a) -> P.Parser a-{-# INLINE scientifically' #-}+{-# INLINABLE scientifically' #-} scientifically' h = "Z.Data.Parser.Numeric.scientifically'" <?> scientificallyInternal' h  -- | Strip message version of scientifically'.@@ -455,9 +532,10 @@                         in i * (expt 10 flen) + f             parseE base flen         _ -> parseE (decLoopIntegerFast intPart) 0-    pure $! if sign /= MINUS then h sci else h (negate sci)+    -- intentionally lazy return here, we have done the grammar check, and h could potentially be very expensive, e.g. sciToDouble+    -- retained references are sign and sci, which are already in NF+    pure (if sign /= MINUS then h sci else h (negate sci))   where-    {-# INLINE parseE #-}     parseE !c !e = do         me <- P.peekMaybe         e' <- case me of

@@ -18,32 +18,78 @@     , timeZone     , utcTime     , zonedTime+    -- * internal+    , fromGregorianValid'+    , fromGregorianValidInt64     ) where  import           Control.Applicative   ((<|>)) import           Data.Fixed            (Fixed (..), Pico) import           Data.Int              (Int64) import           Data.Maybe            (fromMaybe)-import           Data.Time.Calendar    (Day, fromGregorianValid)+import           Data.Time.Calendar    (Day(..), fromGregorianValid) import           Data.Time.Clock       (UTCTime (..)) import           Data.Time.LocalTime   hiding (utc) import           Z.Data.ASCII+import qualified Z.Data.Array          as A import           Z.Data.Parser.Base    (Parser) import qualified Z.Data.Parser.Base    as P import qualified Z.Data.Parser.Numeric as P import qualified Z.Data.Vector         as V+import qualified Z.Data.Text           as T  -- | Parse a date of the form @[+,-]YYYY-MM-DD@.+--+-- Invalid date(leap year rule violation, etc.) will be rejected. day :: Parser Day-day = "date must be of form [+,-]YYYY-MM-DD" P.<?> do-    absOrNeg <- negate <$ P.word8 MINUS <|> id <$ P.word8 PLUS <|> pure id+{-# INLINE day #-}+day = "Date must be of form [+,-]YYYY-MM-DD" P.<?> do     y <- (P.integer <* P.word8 HYPHEN)     m <- (twoDigits <* P.word8 HYPHEN)     d <- twoDigits-    maybe (P.fail' "invalid date") return $! fromGregorianValid (absOrNeg y) m d+    case fromGregorianValid' y m d of+        Just d' -> pure d'+        _ -> P.fail' $ T.concat ["Z.Data.Parser.Time.day: invalid date: ", T.toText y, "-", T.toText m, "-", T.toText d] +-- | Faster 'fromGregorianValid' with 'fromGregorianValidInt64' as the common case path.+--+fromGregorianValid' :: Integer -> Int -> Int -> Maybe Day+{-# INLINE fromGregorianValid' #-}+fromGregorianValid' y m d+    | -18000000000000000 < y  && y < 18000000000000000 = fromGregorianValidInt64 (fromIntegral y) m d+    | otherwise = fromGregorianValid y m d++-- | Faster common case for small years(around -18000000000000000 ~ 18000000000000000).+--+fromGregorianValidInt64 :: Int64 -> Int -> Int -> Maybe Day+{-# INLINABLE fromGregorianValidInt64 #-}+fromGregorianValidInt64 year month day_ =+    if (1 <= month && month <= 12) && (1 <= day_ && day_ <= monthLength)+    -- intentionally not to force with outer 'Just' here, we have done the grammar check, and calculating mjd is expensive,+    -- retained references are year, month and day, which are already in NF+    then Just (ModifiedJulianDay $! fromIntegral mjd)+    else Nothing+  where+    isLeap = (rem year 4 == 0) && ((rem year 400 == 0) || not (rem year 100 == 0))+    dayOfYear =+        let k = if month <= 2 then 0 else if isLeap then -1 else -2+        in ((367 * month - 362) `div` 12) + k + day_+    mjd =+        let y = year - 1+        in (fromIntegral dayOfYear) + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576+    monthLength = A.indexArr (if isLeap then monthListLeap else monthList) (month-1)++monthList :: A.PrimArray Int+{-# NOINLINE monthList #-}+monthList = V.packN 12 [ 31 , 28 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ]++monthListLeap :: A.PrimArray Int+{-# NOINLINE monthListLeap #-}+monthListLeap = V.packN 12 [ 31 , 29 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ]+ -- | Parse a two-digit integer (e.g. day of month, hour). twoDigits :: Parser Int+{-# INLINE twoDigits #-} twoDigits = do     a <- P.digit     b <- P.digit@@ -51,6 +97,7 @@  -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. timeOfDay :: Parser TimeOfDay+{-# INLINE timeOfDay #-} timeOfDay = do     h <- twoDigits     m <- P.char8 ':' *> twoDigits@@ -59,9 +106,9 @@     then return (TimeOfDay h m s)     else P.fail' "invalid time" - -- | Parse a count of seconds, with the integer part being two digits -- long. seconds :: Parser Pico+{-# INLINE seconds #-} seconds = do     real <- twoDigits     mw <- P.peekMaybe@@ -81,6 +128,7 @@ -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) timeZone :: Parser (Maybe TimeZone)+{-# INLINE timeZone #-} timeZone = do     P.skipWhile (== SPACE)     w <- P.satisfy $ \ w -> w == LETTER_Z || w == PLUS || w == MINUS@@ -109,11 +157,13 @@ -- The space may be replaced with a @T@.  The number of seconds is optional -- and may be followed by a fractional component. localTime :: Parser LocalTime+{-# INLINE localTime #-} localTime = LocalTime <$> day <* daySep <*> timeOfDay   where daySep = P.satisfy (\ w -> w == LETTER_T || w == SPACE)  -- | Behaves as 'zonedTime', but converts any time zone offset into a -- UTC time. utcTime :: Parser UTCTime+{-# INLINE utcTime #-} utcTime = do     lt@(LocalTime d t) <- localTime     mtz <- timeZone@@ -136,7 +186,9 @@ -- two digits are hours, the @:@ is optional and the second two digits -- (also optional) are minutes. zonedTime :: Parser ZonedTime+{-# INLINE zonedTime #-} zonedTime = ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)  utc :: TimeZone+{-# INLINE utc #-} utc = TimeZone 0 False ""

@@ -1,31 +1,38 @@ {-|-Module      :  Z.Data.PrimRef+Module      :  Z.Data.PrimRef.PrimRef+Description :  Primitive references Copyright   :  (c) Dong Han 2017~2019 License     :  BSD-style+ Maintainer  :  winterland1989@gmail.com Stability   :  experimental Portability :  portable -This module provide fast unboxed references for ST and IO monad, and atomic operations for 'Counter' type. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of Prim class).-+This package provide fast primitive references for primitive monad, such as ST or IO. Unboxed reference is implemented using single cell @MutableByteArray\/MutableUnliftedArray@ s to eliminate indirection overhead which MutVar# s a carry, on the otherhand primitive reference only support limited type(instances of 'Prim\/PrimUnlifted' class). -} + module Z.Data.PrimRef-  ( -- * Unboxed ST references-    PrimSTRef-  , newPrimSTRef-  , readPrimSTRef-  , writePrimSTRef-  , modifyPrimSTRef-  , -- * Unboxed IO references-    PrimIORef-  , newPrimIORef-  , readPrimIORef-  , writePrimIORef-  , modifyPrimIORef+  ( -- * Prim references+    PrimRef(..), PrimIORef+  , newPrimRef+  , readPrimRef+  , writePrimRef+  , modifyPrimRef+  , Prim(..)+    -- * Unlifted references+  , UnliftedRef(..)+  , newUnliftedRef+  , readUnliftedRef+  , writeUnliftedRef+  , modifyUnliftedRef+  , PrimUnlifted(..)     -- * Atomic operations for @PrimIORef Int@   , Counter   , newCounter+  , readCounter+  , writeCounter+  , modifyCounter     -- ** return value BEFORE atomic operation   , atomicAddCounter   , atomicSubCounter@@ -49,5 +56,209 @@   , atomicXorCounter_   ) where -import Z.Data.PrimRef.PrimSTRef-import Z.Data.PrimRef.PrimIORef+import Control.Monad.Primitive+import Data.Primitive.Types+import Data.Primitive.ByteArray+import GHC.Exts+import GHC.IO+import Z.Data.Array.UnliftedArray++-- | A mutable variable in the 'PrimMonad' which can hold an instance of 'Prim'.+--+newtype PrimRef s a = PrimRef (MutableByteArray s)++-- | Type alias for 'PrimRef' in IO.+type PrimIORef a = PrimRef RealWorld a++-- | Build a new 'PrimRef'+--+newPrimRef :: (Prim a, PrimMonad m) => a -> m (PrimRef (PrimState m) a)+newPrimRef x = do+     mba <- newByteArray (I# (sizeOf# x))+     writeByteArray mba 0 x+     return (PrimRef mba)+{-# INLINE newPrimRef #-}++-- | Read the value of an 'PrimRef'+--+readPrimRef :: (Prim a, PrimMonad m) => PrimRef (PrimState m) a -> m a+readPrimRef (PrimRef mba) = readByteArray mba 0+{-# INLINE readPrimRef #-}++-- | Write a new value into an 'PrimRef'+--+writePrimRef :: (Prim a, PrimMonad m) => PrimRef (PrimState m) a -> a -> m ()+writePrimRef (PrimRef mba) x = writeByteArray mba 0 x+{-# INLINE writePrimRef #-}++-- | Mutate the contents of an 'PrimRef'.+--+--  Unboxed reference is always strict on the value it hold.+--+modifyPrimRef :: (Prim a, PrimMonad m) => PrimRef (PrimState m) a -> (a -> a) -> m ()+modifyPrimRef ref f = readPrimRef ref >>= writePrimRef ref . f+{-# INLINE modifyPrimRef #-}++-- | Alias for 'PrimIORef Int' which support several atomic operations.+type Counter = PrimRef RealWorld Int++-- | Build a new 'Counter'+newCounter :: Int -> IO Counter+newCounter = newPrimRef+{-# INLINE newCounter #-}++-- | Read the value of an 'Counter'.+readCounter :: Counter -> IO Int+readCounter = readPrimRef+{-# INLINE readCounter #-}++-- | Write a new value into an 'Counter'(non-atomically).+writeCounter :: Counter -> Int -> IO ()+writeCounter = writePrimRef+{-# INLINE writeCounter #-}++-- | Mutate the contents of an 'Counter'(non-atomically).+modifyCounter :: Counter -> (Int -> Int) -> IO ()+modifyCounter = modifyPrimRef+{-# INLINE modifyCounter #-}++-- | Atomically add a 'Counter', return the value AFTER added.+atomicAddCounter' :: Counter -> Int -> IO Int+{-# INLINE atomicAddCounter' #-}+atomicAddCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# (res# +# x#)) #)++-- | Atomically add a 'Counter', return the value BEFORE added.+atomicAddCounter :: Counter -> Int -> IO Int+{-# INLINE atomicAddCounter #-}+atomicAddCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)++-- | Atomically add a 'Counter'.+atomicAddCounter_ :: Counter -> Int -> IO ()+atomicAddCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, _ #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, () #)+{-# INLINE atomicAddCounter_ #-}+++-- | Atomically sub a 'Counter', return the value AFTER subbed.+atomicSubCounter' :: Counter -> Int -> IO Int+{-# INLINE atomicSubCounter' #-}+atomicSubCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# (res# -# x#)) #)++-- | Atomically sub a 'Counter', return the value BEFORE subbed.+atomicSubCounter :: Counter -> Int -> IO Int+{-# INLINE atomicSubCounter #-}+atomicSubCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)++-- | Atomically sub a 'Counter'+atomicSubCounter_ :: Counter -> Int -> IO ()+atomicSubCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, _ #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, () #)+{-# INLINE atomicSubCounter_ #-}++-- | Atomically and a 'Counter', return the value AFTER anded.+atomicAndCounter' :: Counter -> Int -> IO Int+atomicAndCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `andI#` x#)) #)+{-# INLINE atomicAndCounter' #-}++-- | Atomically and a 'Counter', return the value BEFORE anded.+atomicAndCounter :: Counter -> Int -> IO Int+atomicAndCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)+{-# INLINE atomicAndCounter #-}++-- | Atomically and a 'Counter'+atomicAndCounter_ :: Counter -> Int -> IO ()+atomicAndCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, _ #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, () #)+{-# INLINE atomicAndCounter_ #-}++-- | Atomically nand a 'Counter', return the value AFTER nanded.+atomicNandCounter' :: Counter -> Int -> IO Int+atomicNandCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# (notI# (res# `andI#` x#))) #)+{-# INLINE atomicNandCounter' #-}++-- | Atomically nand a 'Counter', return the value BEFORE nanded.+atomicNandCounter :: Counter -> Int -> IO Int+atomicNandCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)+{-# INLINE atomicNandCounter #-}++-- | Atomically nand a 'Counter'+atomicNandCounter_ :: Counter -> Int -> IO ()+atomicNandCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, _ #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, () #)+{-# INLINE atomicNandCounter_ #-}++-- | Atomically or a 'Counter', return the value AFTER ored.+atomicOrCounter' :: Counter -> Int -> IO Int+atomicOrCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `orI#` x#)) #)+{-# INLINE atomicOrCounter' #-}++-- | Atomically or a 'Counter', return the value BEFORE ored.+atomicOrCounter :: Counter -> Int -> IO Int+atomicOrCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)+{-# INLINE atomicOrCounter #-}++-- | Atomically or a 'Counter'+atomicOrCounter_ :: Counter -> Int -> IO ()+atomicOrCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, _ #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, () #)+{-# INLINE atomicOrCounter_ #-}++-- | Atomically xor a 'Counter', return the value AFTER xored.+atomicXorCounter' :: Counter -> Int -> IO Int+atomicXorCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `xorI#` x#)) #)+{-# INLINE atomicXorCounter' #-}++-- | Atomically xor a 'Counter', return the value BEFORE xored.+atomicXorCounter :: Counter -> Int -> IO Int+atomicXorCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)+{-# INLINE atomicXorCounter #-}++-- | Atomically xor a 'Counter'+atomicXorCounter_ :: Counter -> Int -> IO ()+atomicXorCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# ->+    let !(# s2#, _ #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, () #)+{-# INLINE atomicXorCounter_ #-}++-- | A mutable variable in the 'PrimMonad' which can hold an instance of 'PrimUnlifted'.+--+newtype UnliftedRef s a = UnliftedRef (MutableUnliftedArray s a)++-- | Build a new 'UnliftedRef'+--+newUnliftedRef :: (PrimUnlifted a, PrimMonad m) => a -> m (UnliftedRef (PrimState m) a)+newUnliftedRef x = do+     mba <- newUnliftedArray 1 x+     return (UnliftedRef mba)+{-# INLINE newUnliftedRef #-}++-- | Read the value of an 'UnliftedRef'+--+readUnliftedRef :: (PrimUnlifted a, PrimMonad m) => UnliftedRef (PrimState m) a -> m a+readUnliftedRef (UnliftedRef mba) = readUnliftedArray mba 0+{-# INLINE readUnliftedRef #-}++-- | Write a new value into an 'UnliftedRef'+--+writeUnliftedRef :: (PrimUnlifted a, PrimMonad m) => UnliftedRef (PrimState m) a -> a -> m ()+writeUnliftedRef (UnliftedRef mba) x = writeUnliftedArray mba 0 x+{-# INLINE writeUnliftedRef #-}++-- | Mutate the contents of an 'UnliftedRef'.+--+--  Unlifted reference is always strict on the value it hold.+--+modifyUnliftedRef :: (PrimUnlifted a, PrimMonad m) => UnliftedRef (PrimState m) a -> (a -> a) -> m ()+modifyUnliftedRef ref f = readUnliftedRef ref >>= writeUnliftedRef ref . f+{-# INLINE modifyUnliftedRef #-}

@@ -1,193 +0,0 @@-{-|-Module      :  Z.Data.PrimIORef-Description :  Primitive IO Reference-Copyright   :  (c) Dong Han 2017~2019-License     :  BSD-style--Maintainer  :  winterland1989@gmail.com-Stability   :  experimental-Portability :  portable--This package provide fast unboxed references for IO monad and atomic operations for 'Counter' type. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of Prim class).--Atomic operations on 'Counter' type are implemented using fetch-and-add primitives, which is much faster than a CAS loop(@atomicModifyIORef@). Beside basic atomic counter usage, you can also leverage idempotence of @and 0@, @or (-1)@ to make a concurrent flag.--}----module Z.Data.PrimRef.PrimIORef-  ( -- * Unboxed IO references-    PrimIORef-  , newPrimIORef-  , readPrimIORef-  , writePrimIORef-  , modifyPrimIORef-    -- * Atomic operations for @PrimIORef Int@-  , Counter-  , newCounter-    -- ** return value BEFORE atomic operation-  , atomicAddCounter-  , atomicSubCounter-  , atomicAndCounter-  , atomicNandCounter-  , atomicOrCounter-  , atomicXorCounter-    -- ** return value AFTER atomic operation-  , atomicAddCounter'-  , atomicSubCounter'-  , atomicAndCounter'-  , atomicNandCounter'-  , atomicOrCounter'-  , atomicXorCounter'-    -- ** without returning-  , atomicAddCounter_-  , atomicSubCounter_-  , atomicAndCounter_-  , atomicNandCounter_-  , atomicOrCounter_-  , atomicXorCounter_-  ) where--import Data.Primitive.Types-import Data.Primitive.ByteArray-import GHC.Exts-import GHC.IO-import Z.Data.PrimRef.PrimSTRef---- | A mutable variable in the IO monad which can hold an instance of 'Prim'.-newtype PrimIORef a = PrimIORef (PrimSTRef RealWorld a)---- | Build a new 'PrimIORef'-newPrimIORef :: Prim a => a -> IO (PrimIORef a)-newPrimIORef x = PrimIORef `fmap` stToIO (newPrimSTRef x)-{-# INLINE newPrimIORef #-}---- | Read the value of an 'PrimIORef'-readPrimIORef :: Prim a => PrimIORef a -> IO a-readPrimIORef (PrimIORef ref) = stToIO (readPrimSTRef ref)-{-# INLINE readPrimIORef #-}---- | Write a new value into an 'PrimIORef'-writePrimIORef :: Prim a => PrimIORef a -> a -> IO ()-writePrimIORef (PrimIORef ref) x = stToIO (writePrimSTRef ref x)-{-# INLINE writePrimIORef #-}---- | Mutate the contents of an 'IORef'.------  Unboxed reference is always strict on the value it hold.-modifyPrimIORef :: Prim a => PrimIORef a -> (a -> a) -> IO ()-modifyPrimIORef ref f = readPrimIORef ref >>= writePrimIORef ref . f-{-# INLINE modifyPrimIORef #-}---- | Alias for 'PrimIORef Int' which support several atomic operations.-type Counter = PrimIORef Int---- | Build a new 'Counter'-newCounter :: Int -> IO Counter-newCounter = newPrimIORef-{-# INLINE newCounter #-}---- | Atomically add a 'Counter', return the value AFTER added.-atomicAddCounter' :: Counter -> Int -> IO Int-atomicAddCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# (res# +# x#)) #)---- | Atomically add a 'Counter', return the value BEFORE added.-atomicAddCounter :: Counter -> Int -> IO Int-atomicAddCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)---- | Atomically add a 'Counter'.-atomicAddCounter_ :: Counter -> Int -> IO ()-atomicAddCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, _ #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, () #)-{-# INLINE atomicAddCounter_ #-}----- | Atomically sub a 'Counter', return the value AFTER subbed.-atomicSubCounter' :: Counter -> Int -> IO Int-atomicSubCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# (res# -# x#)) #)---- | Atomically sub a 'Counter', return the value BEFORE subbed.-atomicSubCounter :: Counter -> Int -> IO Int-atomicSubCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)---- | Atomically sub a 'Counter'-atomicSubCounter_ :: Counter -> Int -> IO ()-atomicSubCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, _ #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, () #)-{-# INLINE atomicSubCounter_ #-}---- | Atomically and a 'Counter', return the value AFTER anded.-atomicAndCounter' :: Counter -> Int -> IO Int-atomicAndCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `andI#` x#)) #)-{-# INLINE atomicAndCounter' #-}---- | Atomically and a 'Counter', return the value BEFORE anded.-atomicAndCounter :: Counter -> Int -> IO Int-atomicAndCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)-{-# INLINE atomicAndCounter #-}---- | Atomically and a 'Counter'-atomicAndCounter_ :: Counter -> Int -> IO ()-atomicAndCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, _ #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, () #)-{-# INLINE atomicAndCounter_ #-}---- | Atomically nand a 'Counter', return the value AFTER nanded.-atomicNandCounter' :: Counter -> Int -> IO Int-atomicNandCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# (notI# (res# `andI#` x#))) #)-{-# INLINE atomicNandCounter' #-}---- | Atomically nand a 'Counter', return the value BEFORE nanded.-atomicNandCounter :: Counter -> Int -> IO Int-atomicNandCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)-{-# INLINE atomicNandCounter #-}---- | Atomically nand a 'Counter'-atomicNandCounter_ :: Counter -> Int -> IO ()-atomicNandCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, _ #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, () #)-{-# INLINE atomicNandCounter_ #-}---- | Atomically or a 'Counter', return the value AFTER ored.-atomicOrCounter' :: Counter -> Int -> IO Int-atomicOrCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `orI#` x#)) #)-{-# INLINE atomicOrCounter' #-}---- | Atomically or a 'Counter', return the value BEFORE ored.-atomicOrCounter :: Counter -> Int -> IO Int-atomicOrCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)-{-# INLINE atomicOrCounter #-}---- | Atomically or a 'Counter'-atomicOrCounter_ :: Counter -> Int -> IO ()-atomicOrCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, _ #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, () #)-{-# INLINE atomicOrCounter_ #-}---- | Atomically xor a 'Counter', return the value AFTER xored.-atomicXorCounter' :: Counter -> Int -> IO Int-atomicXorCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `xorI#` x#)) #)-{-# INLINE atomicXorCounter' #-}---- | Atomically xor a 'Counter', return the value BEFORE xored.-atomicXorCounter :: Counter -> Int -> IO Int-atomicXorCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #)-{-# INLINE atomicXorCounter #-}---- | Atomically xor a 'Counter'-atomicXorCounter_ :: Counter -> Int -> IO ()-atomicXorCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# ->-    let !(# s2#, _ #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, () #)-{-# INLINE atomicXorCounter_ #-}

@@ -1,60 +0,0 @@-{-|-Module      :  Z.Data.PrimRef.PrimSTRef-Description :  Primitive ST Reference-Copyright   :  (c) Dong Han 2017~2019-License     :  BSD-style--Maintainer  :  winterland1989@gmail.com-Stability   :  experimental-Portability :  portable--This package provide fast unboxed references for ST monad. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of 'Prim' class).--}---module Z.Data.PrimRef.PrimSTRef-  ( -- * Unboxed ST references-    PrimSTRef(..)-  , newPrimSTRef-  , readPrimSTRef-  , writePrimSTRef-  , modifyPrimSTRef-  ) where--import Data.Primitive.Types-import Data.Primitive.ByteArray-import GHC.ST-import GHC.Exts---- | A mutable variable in the ST monad which can hold an instance of 'Prim'.----newtype PrimSTRef s a = PrimSTRef (MutableByteArray s)---- | Build a new 'PrimSTRef'----newPrimSTRef :: Prim a => a -> ST s (PrimSTRef s a)-newPrimSTRef x = do-     mba <- newByteArray (I# (sizeOf# x))-     writeByteArray mba 0 x-     return (PrimSTRef mba)-{-# INLINE newPrimSTRef #-}---- | Read the value of an 'PrimSTRef'----readPrimSTRef :: Prim a => PrimSTRef s a -> ST s a-readPrimSTRef (PrimSTRef mba) = readByteArray mba 0-{-# INLINE readPrimSTRef #-}---- | Write a new value into an 'PrimSTRef'----writePrimSTRef :: Prim a => PrimSTRef s a -> a -> ST s ()-writePrimSTRef (PrimSTRef mba) x = writeByteArray mba 0 x-{-# INLINE writePrimSTRef #-}---- | Mutate the contents of an 'PrimSTRef'.------  Unboxed reference is always strict on the value it hold.----modifyPrimSTRef :: Prim a => PrimSTRef s a -> (a -> a) -> ST s ()-modifyPrimSTRef ref f = readPrimSTRef ref >>= writePrimSTRef ref . f-{-# INLINE modifyPrimSTRef #-}

@@ -39,7 +39,7 @@   , map', imap'   , foldl', ifoldl'   , foldr', ifoldr'-  , concat, concatMap+  , concat, concatR, concatMap     -- ** Special folds   , count, all, any     -- ** Text display width

@@ -34,7 +34,7 @@   , map', imap'   , foldl', ifoldl'   , foldr', ifoldr'-  , concat, concatMap+  , concat, concatR, concatMap     -- ** Special folds   , count, all, any     -- ** Text display width@@ -232,13 +232,13 @@ -- | /O(n)/ Get the nth codepoint from 'Text', throw 'IndexOutOfTextRange' -- when out of bound. index :: HasCallStack => Text -> Int -> Char-{-# INLINABLE index #-}+{-# INLINE index #-} index t n = case t `indexMaybe` n of Nothing -> throw (IndexOutOfTextRange n callStack)                                      Just x  -> x  -- | /O(n)/ Get the nth codepoint from 'Text'. indexMaybe :: Text -> Int -> Maybe Char-{-# INLINABLE indexMaybe #-}+{-# INLINE indexMaybe #-} indexMaybe (Text (V.PrimVector ba s l)) n     | n < 0 = Nothing     | otherwise = go s 0@@ -254,7 +254,7 @@ -- The index is only meaningful to the whole byte slice, if there's less than n codepoints, -- the index will point to next byte after the end. charByteIndex :: Text -> Int -> Int-{-# INLINABLE charByteIndex #-}+{-# INLINE charByteIndex #-} charByteIndex (Text (V.PrimVector ba s l)) n     | n < 0 = s     | otherwise = go s 0@@ -268,13 +268,13 @@ -- | /O(n)/ Get the nth codepoint from 'Text' counting from the end, -- throw @IndexOutOfVectorRange n callStack@ when out of bound. indexR :: HasCallStack => Text -> Int -> Char-{-# INLINABLE indexR #-}+{-# INLINE indexR #-} indexR t n = case t `indexMaybeR` n of Nothing -> throw (V.IndexOutOfVectorRange n callStack)                                        Just x  -> x  -- | /O(n)/ Get the nth codepoint from 'Text' counting from the end. indexMaybeR :: Text -> Int -> Maybe Char-{-# INLINABLE indexMaybeR #-}+{-# INLINE indexMaybeR #-} indexMaybeR (Text (V.PrimVector ba s l)) n     | n < 0 = Nothing     | otherwise = go (s+l-1) 0@@ -290,7 +290,7 @@ -- The index is only meaningful to the whole byte slice, if there's less than n codepoints, -- the index will point to previous byte before the start. charByteIndexR :: Text -> Int -> Int-{-# INLINABLE charByteIndexR #-}+{-# INLINE charByteIndexR #-} charByteIndexR (Text (V.PrimVector ba s l)) n     | n < 0 = s+l     | otherwise = go (s+l-1) 0@@ -519,12 +519,12 @@  -- | /O(1)/. Single char text. singleton :: Char -> Text-{-# INLINABLE singleton #-}+{-# INLINE singleton #-} singleton c = Text $ V.createN 4 $ \ marr -> encodeChar marr 0 c  -- | /O(1)/. Empty text. empty :: Text-{-# INLINABLE empty #-}+{-# NOINLINE empty #-} empty = Text V.empty  -- | /O(n)/. Copy a text from slice.@@ -545,12 +545,12 @@  -- | /O(1)/ Test whether a text is empty. null :: Text -> Bool-{-# INLINABLE null #-}+{-# INLINE null #-} null (Text bs) = V.null bs  -- |  /O(n)/ The char length of a text. length :: Text -> Int-{-# INLINABLE length #-}+{-# INLINE length #-} length (Text (V.PrimVector ba s l)) = go s 0   where     !end = s + l@@ -665,6 +665,14 @@ concat = Text . V.concat . coerce {-# INLINE concat #-} +-- | /O(n)/ Concatenate a list of text in reverse order, e.g. @concat ["hello, world"] == "worldhello"@+--+-- Note: 'concat' have to force the entire list to filter out empty text and calculate+-- the length for allocation.+concatR :: [Text] -> Text+concatR = Text . V.concatR . coerce+{-# INLINE concatR #-}+ -- | Map a function over a text and concatenate the results concatMap :: (Char -> Text) -> Text -> Text {-# INLINE concatMap #-}@@ -716,8 +724,8 @@ -- replicate :: Int -> Char -> Text {-# INLINE replicate #-}-replicate 0 _ = empty-replicate n c = Text (V.create siz (go 0))+replicate n c | n <= 0 = empty+              | otherwise = Text (V.create siz (go 0))   where     !csiz = encodeCharLength c     !siz = n * csiz

@@ -69,7 +69,7 @@ -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different -- complexity, as it requires making a copy. cons :: Char -> Text -> Text-{-# INLINABLE cons #-}+{-# INLINE cons #-} cons c (Text (V.PrimVector ba s l)) = Text (V.createN (4 + l) (\ mba -> do     i <- encodeChar mba 0 c     copyPrimArray mba i ba s l@@ -77,7 +77,7 @@  -- | /O(n)/ Append a char to the end of a text. snoc :: Text -> Char -> Text-{-# INLINABLE snoc #-}+{-# INLINE snoc #-} snoc (Text (V.PrimVector ba s l)) c = Text (V.createN (4 + l) (\ mba -> do     copyPrimArray mba 0 ba s l     encodeChar mba l c))@@ -106,71 +106,71 @@ -- -- Throw 'EmptyText' if text is empty. head :: Text -> Char-{-# INLINABLE head #-}+{-# INLINE head #-} head t = case uncons t of { Just (c, _) -> c; _ ->  errorEmptyText }  -- | /O(1)/ Extract the chars after the head of a text. -- -- Throw 'EmptyText' if text is empty. tail :: Text -> Text-{-# INLINABLE tail #-}+{-# INLINE tail #-} tail t = case uncons t of { Nothing -> errorEmptyText; Just (_, t') -> t' }  -- | /O(1)/ Extract the last char of a text. -- -- Throw 'EmptyText' if text is empty. last :: Text ->  Char-{-# INLINABLE last #-}+{-# INLINE last #-} last t = case unsnoc t of { Just (_, c) -> c; _ -> errorEmptyText }  -- | /O(1)/ Extract the chars before of the last one. -- -- Throw 'EmptyText' if text is empty. init :: Text -> Text-{-# INLINABLE init #-}+{-# INLINE init #-} init t = case unsnoc t of { Just (t', _) -> t'; _ -> errorEmptyText }  -- | /O(1)/ Extract the first char of a text. headMaybe :: Text -> Maybe Char-{-# INLINABLE headMaybe #-}+{-# INLINE headMaybe #-} headMaybe t = case uncons t of { Just (c, _) -> Just c; _ -> Nothing }  -- | /O(1)/ Extract the chars after the head of a text. -- -- NOTE: 'tailMayEmpty' return empty text in the case of an empty text. tailMayEmpty :: Text -> Text-{-# INLINABLE tailMayEmpty #-}+{-# INLINE tailMayEmpty #-} tailMayEmpty t = case uncons t of { Nothing -> empty; Just (_, t') -> t' }  -- | /O(1)/ Extract the last char of a text. lastMaybe :: Text -> Maybe Char-{-# INLINABLE lastMaybe #-}+{-# INLINE lastMaybe #-} lastMaybe t = case unsnoc t of { Just (_, c) -> Just c; _ -> Nothing }  -- | /O(1)/ Extract the chars before of the last one. -- -- NOTE: 'initMayEmpty' return empty text in the case of an empty text. initMayEmpty :: Text -> Text-{-# INLINABLE initMayEmpty #-}+{-# INLINE initMayEmpty #-} initMayEmpty t = case unsnoc t of { Just (t', _) -> t'; _ -> empty }  -- | /O(n)/ Return all initial segments of the given text, empty first. inits :: Text -> [Text]-{-# INLINABLE inits #-}+{-# INLINE inits #-} inits t0 = go t0 [t0]   where go t acc = case unsnoc t of Just (t', _) -> go t' (t':acc)                                     Nothing      -> acc  -- | /O(n)/ Return all final segments of the given text, whole text first. tails :: Text -> [Text]-{-# INLINABLE tails #-}+{-# INLINE tails #-} tails t = t : case uncons t of Just (_, t') -> tails t'                                Nothing      -> []  -- | /O(1)/ 'take' @n@, applied to a text @xs@, returns the prefix -- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. take :: Int -> Text -> Text-{-# INLINABLE take #-}+{-# INLINE take #-} take n t@(Text (V.PrimVector ba s _))     | n <= 0 = empty     | otherwise = case charByteIndex t n of i -> Text (V.PrimVector ba s (i-s))@@ -178,7 +178,7 @@ -- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ -- char, or @[]@ if @n > 'length' xs@. drop :: Int -> Text -> Text-{-# INLINABLE drop #-}+{-# INLINE drop #-} drop n t@(Text (V.PrimVector ba s l))     | n <= 0 = t     | otherwise = case charByteIndex t n of i -> Text (V.PrimVector ba i (l+s-i))@@ -186,7 +186,7 @@ -- | /O(1)/ 'takeR' @n@, applied to a text @xs@, returns the suffix -- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. takeR :: Int -> Text -> Text-{-# INLINABLE takeR #-}+{-# INLINE takeR #-} takeR n t@(Text (V.PrimVector ba s l))     | n <= 0 = empty     | otherwise = case charByteIndexR t n of i -> Text (V.PrimVector ba (i+1) (s+l-1-i))@@ -194,7 +194,7 @@ -- | /O(1)/ 'dropR' @n xs@ returns the prefix of @xs@ before the last @n@ -- char, or @[]@ if @n > 'length' xs@. dropR :: Int -> Text -> Text-{-# INLINABLE dropR #-}+{-# INLINE dropR #-} dropR n t@(Text (V.PrimVector ba s _))     | n <= 0 = t     | otherwise = case charByteIndexR t n of i -> Text (V.PrimVector ba s (i-s+1))@@ -338,7 +338,7 @@  -- | The 'groupBy' function is the non-overloaded version of 'group'. groupBy :: (Char -> Char -> Bool) -> Text -> [Text]-{-# INLINE groupBy #-}+{-# INLINABLE groupBy #-} groupBy f (Text (V.PrimVector arr s l))     | l == 0    = []     | otherwise = Text (V.PrimVector arr s (s'-s)) : groupBy f (Text (V.PrimVector arr s' (l+s-s')))@@ -356,13 +356,13 @@ -- 'Nothing'. -- stripPrefix :: Text -> Text -> Maybe Text-{-# INLINE stripPrefix #-}+{-# INLINABLE stripPrefix #-} stripPrefix = coerce (V.stripPrefix @V.PrimVector @Word8)   -- | O(n) The 'stripSuffix' function takes two texts and returns Just the remainder of the second iff the first is its suffix, and otherwise Nothing. stripSuffix :: Text -> Text -> Maybe Text-{-# INLINE stripSuffix #-}+{-# INLINABLE stripSuffix #-} stripSuffix = coerce (V.stripSuffix @V.PrimVector @Word8)  -- | /O(n)/ Break a text into pieces separated by the delimiter element@@ -380,7 +380,7 @@ -- NOTE, this function behavior different with bytestring's. see -- <https://github.com/haskell/bytestring/issues/56 #56>. split :: Char -> Text -> [Text]-{-# INLINE split #-}+{-# INLINABLE split #-} split x = splitWith (==x)  -- | /O(n)/ Splits a text into components delimited by@@ -392,7 +392,7 @@ -- > splitWith (=='a') []        == [""] -- splitWith :: (Char -> Bool) -> Text -> [Text]-{-# INLINE splitWith #-}+{-# INLINABLE splitWith #-} splitWith f (Text (V.PrimVector arr s l)) = go s s   where     !end = s + l@@ -422,25 +422,25 @@ -- > intercalate s . splitOn s         == id -- > splitOn (singleton c)             == split (==c) splitOn :: Text -> Text -> [Text]-{-# INLINE splitOn #-}+{-# INLINABLE splitOn #-} splitOn = coerce (V.splitOn @V.PrimVector @Word8)  -- | The 'isPrefix' function returns 'True' if the first argument is a prefix of the second. isPrefixOf :: Text -> Text -> Bool-{-# INLINE isPrefixOf #-}+{-# INLINABLE isPrefixOf #-} isPrefixOf = coerce (V.isPrefixOf @V.PrimVector @Word8)  -- | /O(n)/ The 'isSuffixOf' function takes two text and returns 'True' -- if the first is a suffix of the second. isSuffixOf :: Text -> Text -> Bool-{-# INLINE isSuffixOf #-}+{-# INLINABLE isSuffixOf #-} isSuffixOf = coerce (V.isSuffixOf @V.PrimVector @Word8)  -- | Check whether one text is a subtext of another. -- -- @needle `isInfixOf` haystack === null haystack || indices needle haystake /= []@. isInfixOf :: Text -> Text -> Bool-{-# INLINE isInfixOf #-}+{-# INLINABLE isInfixOf #-} isInfixOf = coerce (V.isInfixOf @V.PrimVector @Word8)  -- | /O(n)/ Find the longest non-empty common prefix of two strings@@ -453,12 +453,12 @@ -- >>> commonPrefix "veeble" "fetzer" -- ("","veeble","fetzer") commonPrefix :: Text -> Text -> (Text, Text, Text)-{-# INLINE commonPrefix #-}+{-# INLINABLE commonPrefix #-} commonPrefix = coerce (V.commonPrefix @V.PrimVector @Word8)  -- | /O(n)/ Breaks a 'Bytes' up into a list of words, delimited by unicode space. words ::  Text -> [Text]-{-# INLINE words #-}+{-# INLINABLE words #-} words (Text (V.PrimVector arr s l)) = go s s   where     !end = s + l@@ -476,24 +476,24 @@  -- | /O(n)/ Breaks a text up into a list of lines, delimited by ascii @\n@. lines :: Text -> [Text]-{-# INLINE lines #-}+{-# INLINABLE lines #-} lines = coerce V.lines  -- | /O(n)/ Joins words with ascii space. unwords :: [Text] -> Text-{-# INLINE unwords #-}+{-# INLINABLE unwords #-} unwords = coerce V.unwords  -- | /O(n)/ Joins lines with ascii @\n@. -- -- NOTE: This functions is different from 'Prelude.unlines', it DOES NOT add a trailing @\n@. unlines :: [Text] -> Text-{-# INLINE unlines #-}+{-# INLINABLE unlines #-} unlines = coerce V.unlines  -- | Add padding to the left so that the whole text's length is at least n. padLeft :: Int -> Char -> Text -> Text-{-# INLINE padLeft #-}+{-# INLINABLE padLeft #-} padLeft n c t@(Text (V.PrimVector arr s l))     | n <= tsiz = t     | otherwise =@@ -513,7 +513,7 @@  -- | Add padding to the right so that the whole text's length is at least n. padRight :: Int -> Char -> Text -> Text-{-# INLINE padRight #-}+{-# INLINABLE padRight #-} padRight n c t@(Text (V.PrimVector arr s l))     | n <= tsiz = t     | otherwise =@@ -539,7 +539,7 @@ -- between the characters of a 'Text'. Performs replacement on invalid scalar values. -- intersperse :: Char -> Text -> Text-{-# INLINE intersperse #-}+{-# INLINABLE intersperse #-} intersperse c = \ t@(Text (V.PrimVector ba s l)) ->     let tlen = length t     in if length t < 2@@ -575,7 +575,7 @@  -- | /O(n)/ Reverse the characters of a string. reverse :: Text -> Text-{-# INLINE reverse #-}+{-# INLINABLE reverse #-} reverse = \ (Text (V.PrimVector ba s l)) -> Text $ V.create l (go ba s l (s+l))   where     go :: PrimArray Word8 -> Int -> Int -> Int -> MutablePrimArray s Word8 -> ST s ()@@ -591,17 +591,17 @@ -- 'Text's and concatenates the list after interspersing the first -- argument between each element of the list. intercalate :: Text -> [Text] -> Text-{-# INLINE intercalate #-}+{-# INLINABLE intercalate #-} intercalate s = concat . List.intersperse s  intercalateElem :: Char -> [Text] -> Text-{-# INLINE intercalateElem #-}+{-# INLINABLE intercalateElem #-} intercalateElem c = concat . List.intersperse (singleton c)  -- | The 'transpose' function transposes the rows and columns of its -- text argument. -- transpose :: [Text] -> [Text]-{-# INLINE transpose #-}+{-# INLINABLE transpose #-} transpose ts = List.map pack . List.transpose . List.map unpack $ ts 

@@ -137,22 +137,22 @@  -- | Convert data to 'B.Builder'. toUTF8Builder :: Print a => a  -> B.Builder ()-{-# INLINE toUTF8Builder #-}+{-# INLINABLE toUTF8Builder #-} toUTF8Builder = toUTF8BuilderP 0  -- | Convert data to 'V.Bytes' in UTF8 encoding. toUTF8Bytes :: Print a => a -> V.Bytes-{-# INLINE toUTF8Bytes #-}+{-# INLINABLE toUTF8Bytes #-} toUTF8Bytes = B.build . toUTF8BuilderP 0  -- | Convert data to 'Text'. toText :: Print a => a -> Text-{-# INLINE toText #-}+{-# INLINABLE toText #-} toText = Text . toUTF8Bytes  -- | Convert data to 'String', faster 'show' replacement. toString :: Print a => a -> String-{-# INLINE toString #-}+{-# INLINABLE toString #-} toString = T.unpack . toText  class GToText f where@@ -284,7 +284,7 @@ -- @ -- escapeTextJSON :: T.Text -> B.Builder ()-{-# INLINE escapeTextJSON #-}+{-# INLINABLE escapeTextJSON #-} escapeTextJSON (T.Text (V.PrimVector ba@(PrimArray ba#) s l)) = do     let !siz = escape_json_string_length ba# s l     B.writeN siz (\ mba@(MutablePrimArray mba#) i -> do

@@ -34,7 +34,7 @@  -- | find all char index matching the predicate. findIndices :: (Char -> Bool) -> Text -> [Int]-{-# INLINE findIndices #-}+{-# INLINABLE findIndices #-} findIndices f (Text (V.PrimVector arr s l)) = go 0 s   where     !end = s + l@@ -45,7 +45,7 @@  -- | find all char's byte index matching the predicate. findBytesIndices :: (Char -> Bool) -> Text -> [Int]-{-# INLINE findBytesIndices #-}+{-# INLINABLE findBytesIndices #-} findBytesIndices f (Text (V.PrimVector arr s l)) = go s   where     !end = s + l@@ -59,7 +59,7 @@ find :: (Char -> Bool)      -> Text      -> (Int, Maybe Char)  -- ^ (char index, matching char)-{-# INLINE find #-}+{-# INLINABLE find #-} find f (Text (V.PrimVector arr s l)) = go 0 s   where     !end = s + l@@ -76,7 +76,7 @@ findR :: (Char -> Bool)       -> Text       -> (Int, Maybe Char)  -- ^ (char index(counting backwards), matching char)-{-# INLINE findR #-}+{-# INLINABLE findR #-} findR f (Text (V.PrimVector arr s l)) = go 0 (s+l-1)   where     go !i !j | j < s     = (i, Nothing)@@ -90,17 +90,17 @@  -- | /O(n)/ find the char index. findIndex :: (Char -> Bool) -> Text -> Int-{-# INLINE findIndex #-}+{-# INLINABLE findIndex #-} findIndex f t = case find f t of (i, _) -> i  -- | /O(n)/ find the char index in reverse order. findIndexR ::  (Char -> Bool) -> Text -> Int-{-# INLINE findIndexR #-}+{-# INLINABLE findIndexR #-} findIndexR f t = case findR f t of (i, _) -> i  -- | /O(n)/ find the char's byte slice index. findBytesIndex :: (Char -> Bool) -> Text -> Int-{-# INLINE findBytesIndex #-}+{-# INLINABLE findBytesIndex #-} findBytesIndex f (Text (V.PrimVector arr s l)) = go s   where     !end = s + l@@ -113,7 +113,7 @@  -- | /O(n)/ find the char's byte slice index in reverse order(pointing to the right char's first byte). findBytesIndexR ::  (Char -> Bool) -> Text -> Int-{-# INLINE findBytesIndexR #-}+{-# INLINABLE findBytesIndexR #-} findBytesIndexR f (Text (V.PrimVector arr s l)) = go (s+l-1)   where     go !j | j < s     = j-s+1@@ -127,7 +127,7 @@ -- returns a text containing those chars that satisfy the -- predicate. filter :: (Char -> Bool) -> Text -> Text-{-# INLINE filter #-}+{-# INLINABLE filter #-} filter f (Text (V.PrimVector arr s l)) = Text (V.createN l (go s 0))   where     !end = s + l@@ -148,7 +148,7 @@ -- -- > partition p txt == (filter p txt, filter (not . p) txt) partition :: (Char -> Bool) -> Text -> (Text, Text)-{-# INLINE partition #-}+{-# INLINABLE partition #-} partition f (Text (V.PrimVector arr s l))     | l == 0    = (empty, empty)     | otherwise = let !(bs1, bs2) = V.createN2 l l (go 0 0 s) in (Text bs1, Text bs2)@@ -168,11 +168,11 @@  -- | /O(n)/ 'elem' test if given char is in given text. elem :: Char -> Text -> Bool-{-# INLINE elem #-}+{-# INLINABLE elem #-} elem x t = case find (x==) t of (_,Nothing) -> False                                 _           -> True  -- | /O(n)/ @not . elem@ notElem ::  Char -> Text -> Bool-{-# INLINE notElem #-}+{-# INLINABLE notElem #-} notElem x = not . elem x

@@ -81,10 +81,11 @@   , length   , append   , map, map', imap', traverse, traverseWithIndex, traverse_, traverseWithIndex_+  , mapM, mapM_, forM, forM_   , foldl', ifoldl', foldl1', foldl1Maybe'   , foldr', ifoldr', foldr1', foldr1Maybe'     -- ** Special folds-  , concat, concatMap+  , concat, concatR, concatMap   , maximum, minimum, maximumMaybe, minimumMaybe   , sum   , count

@@ -41,10 +41,11 @@   , length   , append   , map, map', imap', traverse, traverseWithIndex, traverse_, traverseWithIndex_+  , mapM, mapM_, forM, forM_   , foldl', ifoldl', foldl1', foldl1Maybe'   , foldr', ifoldr', foldr1', foldr1Maybe'     -- ** Special folds-  , concat, concatMap+  , concat, concatR, concatMap   , maximum, minimum, maximumMaybe, minimumMaybe   , sum   , count, countBytes@@ -86,8 +87,7 @@  import           Control.DeepSeq import           Control.Exception-import           Control.Monad                  hiding (replicateM)-import qualified Control.Monad                  as M (replicateM)+import qualified Control.Monad                  as M import           Control.Monad.ST import           Control.Monad.Primitive import           Data.Bits@@ -101,7 +101,6 @@ import           Data.Maybe import qualified Data.CaseInsensitive           as CI import           Data.Primitive-import           Data.Primitive.Ptr import           Data.Semigroup                 (Semigroup (..)) import qualified Data.Traversable               as T import           Foreign.C@@ -109,7 +108,7 @@ import           GHC.Stack import           GHC.CString import           GHC.Word-import           Prelude                        hiding (concat, concatMap,+import           Prelude                        hiding (concat, concatMap, mapM, mapM_,                                                 elem, notElem, null, length, map,                                                 foldl, foldl1, foldr, foldr1,                                                 maximum, minimum, product, sum,@@ -220,7 +219,7 @@     fromListN = packN  instance Eq a => Eq (Vector a) where-    {-# INLINABLE (==) #-}+    {-# INLINE (==) #-}     v1 == v2 = eqVector v1 v2  eqVector :: Eq a => Vector a -> Vector a -> Bool@@ -237,7 +236,7 @@             (indexSmallArray baA i == indexSmallArray baB j) && go (i+1) (j+1)  instance Ord a => Ord (Vector a) where-    {-# INLINABLE compare #-}+    {-# INLINE compare #-}     compare = compareVector  compareVector :: Ord a => Vector a -> Vector a -> Ordering@@ -358,23 +357,33 @@ {-# INLINE [1] traverseWithIndex #-} {-# RULES "traverseWithIndex/IO" forall (f :: Int -> a -> IO b). traverseWithIndex f = traverseWithIndexPM f #-} {-# RULES "traverseWithIndex/ST" forall (f :: Int -> a -> ST s b). traverseWithIndex f = traverseWithIndexPM f #-}-traverseWithIndex f v = packN (length v) <$> zipWithM f [0..] (unpack v)+traverseWithIndex f v = packN (length v) <$> M.zipWithM f [0..] (unpack v) +-- | 'PrimMonad' specialzied version of 'traverseWithIndex'.+--+-- You can add rules to rewrite 'traverse' and 'traverseWithIndex' to this function in your own 'PrimMonad' instance, e.g.+--+-- @+-- instance PrimMonad YourMonad where ...+--+-- {-# RULES "traverse\/YourMonad" forall (f :: a -> YourMonad b). traverse\' f = traverseWithIndexPM (const f) #-}+-- {-# RULES "traverseWithIndex\/YourMonad" forall (f :: Int -> a -> YourMonad b). traverseWithIndex f = traverseWithIndexPM f #-}+-- @+-- traverseWithIndexPM :: forall m v u a b. (PrimMonad m, Vec v a, Vec u b) => (Int -> a -> m b) -> v a -> m (u b) {-# INLINE traverseWithIndexPM #-} traverseWithIndexPM f (Vec arr s l)     | l == 0    = return empty     | otherwise = do-        marr <- newArr l+        !marr <- newArr l         ba <- go marr 0         return $! fromArr ba 0 l   where     go :: MArr (IArray u) (PrimState m) b -> Int -> m (IArray u b)-    go !marr !i+    go marr !i         | i >= l = unsafeFreezeArr marr         | otherwise = do-            x <- indexArrM arr (i+s)-            writeArr marr i =<< f i x+            writeArr marr i =<< f i (indexArr arr (i+s))             go marr (i+1)  -- | Traverse vector without gathering result.@@ -397,6 +406,27 @@         | i >= end = pure ()         | otherwise = f (i-s) (indexArr arr i) *> go (i+1) +-- | Alias for 'traverse'.+mapM ::  (Vec v a, Vec u b, Applicative f) => (a -> f b) -> v a -> f (u b)+{-# INLINE mapM #-}+mapM = traverse++-- | Alias for 'traverse_'.+mapM_ ::  (Vec v a, Applicative f) => (a -> f b) -> v a -> f ()+{-# INLINE mapM_ #-}+mapM_ = traverse_++-- | Flipped version of 'traverse'.+forM ::  (Vec v a, Vec u b, Applicative f) => v a -> (a -> f b) -> f (u b)+{-# INLINE forM #-}+forM v f = traverse f v++-- | Flipped version of 'traverse_'.+forM_ ::  (Vec v a, Applicative f) => v a -> (a -> f b) -> f ()+{-# INLINE forM_ #-}+forM_ v f = traverse_ f v++ -------------------------------------------------------------------------------- -- | Primitive vector --@@ -577,8 +607,7 @@        -> (forall s. MArr (IArray v) s a -> ST s ())   -- ^ initialization function        -> v a {-# INLINE create #-}-create n0 fill = runST (do-        let n = max 0 n0+create n fill = assert (n >= 0) $ runST (do         marr <- newArr n         fill marr         ba <- unsafeFreezeArr marr@@ -593,8 +622,7 @@         -- ^ initialization function return a result size and array, the result must start from index 0         -> v a {-# INLINE create' #-}-create' n0 fill = runST (do-        let n = max 0 n0+create' n fill = assert (n >= 0) $ runST (do         marr <- newArr n         IPair n' marr' <- fill marr         shrinkMutableArr marr' n'@@ -611,8 +639,7 @@          -> (forall s. MArr (IArray v) s a -> ST s b)  -- ^ initialization function          -> (b, v a) {-# INLINE creating #-}-creating n0 fill = runST (do-        let n = max 0 n0+creating n fill = assert (n >= 0) $ runST (do         marr <- newArr n         b <- fill marr         ba <- unsafeFreezeArr marr@@ -629,8 +656,7 @@          -> (forall s. MArr (IArray v) s a -> ST s (b, (IPair (MArr (IArray v) s a))))  -- ^ initialization function          -> (b, v a) {-# INLINE creating' #-}-creating' n0 fill = runST (do-        let n = max 0 n0+creating' n fill = assert (n >= 0) $ runST (do         marr <- newArr n         (b, IPair n' marr') <- fill marr         shrinkMutableArr marr' n'@@ -690,6 +716,7 @@ -- | /O(1)/. The empty vector. -- empty :: Vec v a => v a+{-# NOINLINE empty #-} empty = Vec emptyArr 0 0  -- | /O(1)/. Single element vector.@@ -725,7 +752,7 @@ {-# INLINE [1] packN #-} packN n0 = \ ws0 -> runST (do let n = max 4 n0                               marr <- newArr n-                              (IPair i marr') <- foldM go (IPair 0 marr) ws0+                              (IPair i marr') <- M.foldM go (IPair 0 marr) ws0                               shrinkMutableArr marr' i                               ba <- unsafeFreezeArr marr'                               return $! fromArr ba 0 i)@@ -754,15 +781,24 @@ {-# RULES "replicateM/ST" forall n (x :: ST s a). replicateM n x = replicatePM n x #-} replicateM n f = packN n <$> M.replicateM n f --- | A version of 'replicateM' which works on 'PrimMonad' and 'Vec'.+-- | 'PrimMonad' specialzied version of 'replicateM'.+--+-- You can add rules to rewrite 'replicateM' to this function in your own 'PrimMonad' instance, e.g.+--+-- @+-- instance PrimMonad YourMonad where ...+--+-- {-# RULES "replicateM\/YourMonad" forall n (f :: YourMonad a). replicateM n f = replicatePM n f #-}+-- @+-- replicatePM :: (PrimMonad m, Vec v a) => Int -> m a -> m (v a) {-# INLINE replicatePM #-} replicatePM n f = do-    marr <- newArr n+    !marr <- newArr n     ba <- go marr 0-    (return $! fromArr ba 0 n)+    return $! fromArr ba 0 n   where-    go marr i+    go marr !i         | i >= n = unsafeFreezeArr marr         | otherwise = do             x <- f@@ -778,7 +814,7 @@ packN' :: forall v a. Vec v a => Int -> [a] -> v a {-# INLINE packN' #-} packN' n = \ ws0 -> runST (do marr <- newArr n-                              (IPair i marr') <- foldM go (IPair 0 marr) ws0+                              (IPair i marr') <- M.foldM go (IPair 0 marr) ws0                               shrinkMutableArr marr' i                               ba <- unsafeFreezeArr marr'                               return $! fromArr ba 0 i)@@ -806,7 +842,7 @@ {-# INLINE packRN #-} packRN n0 = \ ws0 -> runST (do let n = max 4 n0                                marr <- newArr n-                               (IPair i marr') <- foldM go (IPair (n-1) marr) ws0+                               (IPair i marr') <- M.foldM go (IPair (n-1) marr) ws0                                ba <- unsafeFreezeArr marr'                                let i' = i + 1                                    n' = sizeofArr ba@@ -834,7 +870,7 @@ packRN' :: forall v a. Vec v a => Int -> [a] -> v a {-# INLINE packRN' #-} packRN' n = \ ws0 -> runST (do marr <- newArr n-                               (IPair i marr') <- foldM go (IPair (n-1) marr) ws0+                               (IPair i marr') <- M.foldM go (IPair (n-1) marr) ws0                                ba <- unsafeFreezeArr marr'                                let i' = i + 1                                    n' = sizeofArr ba@@ -1070,25 +1106,43 @@ -- Note: 'concat' have to force the entire list to filter out empty vector and calculate -- the length for allocation. concat :: forall v a . Vec v a => [v a] -> v a-{-# INLINE concat #-}+{-# INLINABLE concat #-} concat [v] = v  -- shortcut common case in Parser-concat vs = case pre 0 0 vs of+concat vs = case preConcat 0 0 vs of     (1, _) -> let Just v = List.find (not . null) vs in v -- there must be a not null vector     (_, l) -> create l (go vs 0)   where-    -- pre scan to decide if we really need to copy and calculate total length-    -- we don't accumulate another result list, since it's rare to got empty-    pre :: Int -> Int -> [v a] -> (Int, Int)-    pre !nacc !lacc [] = (nacc, lacc)-    pre !nacc !lacc (Vec _ _ l:vs')-        | l <= 0    = pre nacc lacc vs'-        | otherwise = pre (nacc+1) (l+lacc) vs'-     go :: [v a] -> Int -> MArr (IArray v) s a -> ST s ()     go [] !_ !_                  = return ()-    go (Vec ba s l:vs') !i !marr = do when (l /= 0) (copyArr marr i ba s l)+    go (Vec ba s l:vs') !i !marr = do M.when (l /= 0) (copyArr marr i ba s l)                                       go vs' (i+l) marr +-- | /O(n)/ Concatenate a list of vector in reverse order, e.g. @concat ["hello, world"] == "worldhello"@+--+-- Note: 'concatR' have to force the entire list to filter out empty vector and calculate+-- the length for allocation.+concatR :: forall v a . Vec v a => [v a] -> v a+{-# INLINABLE concatR #-}+concatR [v] = v  -- shortcut common case in Parser+concatR vs = case preConcat 0 0 vs of+    (1, _) -> let Just v = List.find (not . null) vs in v -- there must be a not null vector+    (_, l) -> create l (go vs l)+  where+    go :: [v a] -> Int -> MArr (IArray v) s a -> ST s ()+    go [] !_ !_                  = return ()+    go (Vec ba s l:vs') !i !marr = do M.when (l /= 0) (copyArr marr (i-l) ba s l)+                                      go vs' (i-l) marr++-- pre scan to decide if we really need to copy and calculate total length+-- we don't accumulate another result list, since it's rare to got empty+preConcat :: Vec v a => Int -> Int -> [v a] -> (Int, Int)+{-# INLINE preConcat #-}+preConcat !nacc !lacc [] = (nacc, lacc)+preConcat !nacc !lacc (Vec _ _ l:vs')+    | l <= 0    = preConcat nacc lacc vs'+    | otherwise = preConcat (nacc+1) (l+lacc) vs'++ -- | Map a function over a vector and concatenate the results concatMap :: Vec v a => (a -> v a) -> v a -> v a {-# INLINE concatMap #-}@@ -1416,6 +1470,7 @@  -- | Cast between vectors castVector :: (Vec v a, Cast a b) => v a -> v b+{-# INLINE castVector #-} castVector = unsafeCoerce#  --------------------------------------------------------------------------------

@@ -45,12 +45,12 @@  -- | Return the encoded length of a given input length, always a multipler of 4. base64EncodeLength :: Int -> Int-{-# INLINABLE base64EncodeLength #-}+{-# INLINE base64EncodeLength #-} base64EncodeLength n = ((n+2) `quot` 3) `unsafeShiftL` 2  -- | 'B.Builder' version of 'base64Encode'. base64EncodeBuilder :: V.Bytes -> B.Builder ()-{-# INLINABLE base64EncodeBuilder #-}+{-# INLINE base64EncodeBuilder #-} base64EncodeBuilder (V.PrimVector arr s l) =     B.writeN (base64EncodeLength l) (\ (MutablePrimArray mba#) i -> do         withPrimArrayUnsafe arr $ \ parr _ ->@@ -94,7 +94,7 @@ -- | Return the upper bound of decoded length of a given input length -- , return -1 if illegal(not a multipler of 4). base64DecodeLength :: Int -> Int-{-# INLINABLE base64DecodeLength #-}+{-# INLINE base64DecodeLength #-} base64DecodeLength n | n .&. 3 == 1 = -1                      | otherwise = (n `unsafeShiftR` 2) * 3 + 2 

@@ -227,7 +227,9 @@ -- returns the longest prefix (possibly empty) of @vs@ of elements that -- satisfy @p@. takeWhile :: Vec v a => (a -> Bool) -> v a -> v a-{-# INLINE takeWhile #-}+{-# INLINE [1] takeWhile #-}+{-# RULES "takeWhile/breakEq1" forall w. takeWhile (w `neWord8`) = fst . break (w `eqWord8`) #-}+{-# RULES "takeWhile/breakEq2" forall w. takeWhile (`neWord8` w) = fst . break (`eqWord8` w) #-} takeWhile f v@(Vec arr s _) =     case findIndex (not . f) v of         0  -> empty@@ -237,7 +239,9 @@ -- returns the longest suffix (possibly empty) of @vs@ of elements that -- satisfy @p@. takeWhileR :: Vec v a => (a -> Bool) -> v a -> v a-{-# INLINE takeWhileR #-}+{-# INLINE [1] takeWhileR #-}+{-# RULES "takeWhileR/breakREq1" forall w. takeWhileR (w `neWord8`) = snd . breakR (w `eqWord8`) #-}+{-# RULES "takeWhileR/breakREq2" forall w. takeWhileR (`neWord8` w) = snd . breakR (`eqWord8` w) #-} takeWhileR f v@(Vec arr s l) =     case findIndexR (not . f) v of         -1 -> v@@ -246,7 +250,9 @@ -- | /O(n)/ Applied to a predicate @p@ and a vector @vs@, -- returns the suffix (possibly empty) remaining after 'takeWhile' @p vs@. dropWhile :: Vec v a => (a -> Bool) -> v a -> v a-{-# INLINE dropWhile #-}+{-# INLINE [1] dropWhile #-}+{-# RULES "dropWhile/breakEq1" forall w. dropWhile (w `neWord8`) = snd . break (w `eqWord8`) #-}+{-# RULES "dropWhile/breakEq2" forall w. dropWhile (`neWord8` w) = snd . break (`eqWord8` w) #-} dropWhile f v@(Vec arr s l) =     case findIndex (not . f) v of         i | i == l     -> empty@@ -255,7 +261,9 @@ -- | /O(n)/ Applied to a predicate @p@ and a vector @vs@, -- returns the prefix (possibly empty) remaining before 'takeWhileR' @p vs@. dropWhileR :: Vec v a => (a -> Bool) -> v a -> v a-{-# INLINE dropWhileR #-}+{-# INLINE [1] dropWhileR #-}+{-# RULES "dropWhileR/breakEq1" forall w. dropWhileR (w `neWord8`) = fst . breakR (w `eqWord8`) #-}+{-# RULES "dropWhileR/breakEq2" forall w. dropWhileR (`neWord8` w) = fst . breakR (`eqWord8` w) #-} dropWhileR f v@(Vec arr s _) =     case findIndexR (not . f) v of         -1 -> empty@@ -283,11 +291,11 @@ -- @span (/=x)@ will be rewritten using a @memchr@. span :: Vec v a => (a -> Bool) -> v a -> (v a, v a) {-# INLINE [1] span #-}-span f = break (not . f) {-# RULES "spanNEq/breakEq1" forall w. span (w `neWord8`) = break (w `eqWord8`) #-} {-# RULES "spanNEq/breakEq2" forall w. span (`neWord8` w) = break (`eqWord8` w) #-}+span f = break (not . f) --- | 'breakR' behaves like 'break' but from the end of the vector.+-- | 'breakR' behaves like 'break' but apply predictor from the end of the vector. -- -- @breakR p == spanR (not.p)@ breakR :: Vec v a => (a -> Bool) -> v a -> (v a, v a)@@ -300,7 +308,9 @@  -- | 'spanR' behaves like 'span' but from the end of the vector. spanR :: Vec v a => (a -> Bool) -> v a -> (v a, v a)-{-# INLINE spanR #-}+{-# INLINE [1]  spanR #-}+{-# RULES "spanNEq/breakREq1" forall w. spanR (w `neWord8`) = breakR (w `eqWord8`) #-}+{-# RULES "spanNEq/breakREq2" forall w. spanR (`neWord8` w) = breakR (`eqWord8` w) #-} spanR f = breakR (not . f)  -- | Break a vector on a subvector, returning a pair of the part of the@@ -309,7 +319,7 @@ -- > break "wor" "hello, world" = ("hello, ", "world") -- breakOn :: (Vec v a, Eq a) => v a -> v a -> (v a, v a)-{-# INLINE breakOn #-}+{-# INLINABLE breakOn #-} breakOn needle = \ haystack@(Vec arr s l) ->     case search haystack False of         (i:_) -> let !v1 = Vec arr s i@@ -320,11 +330,11 @@   group :: (Vec v a, Eq a) => v a -> [v a]-{-# INLINE group #-}+{-# INLINABLE group #-} group = groupBy (==)  groupBy :: forall v a. Vec v a =>  (a -> a -> Bool) -> v a -> [v a]-{-# INLINE groupBy #-}+{-# INLINABLE groupBy #-} groupBy f (Vec arr s l)     | l == 0    = []     | otherwise = Vec arr s n : groupBy f (Vec arr (s+n) (l-n))@@ -339,7 +349,7 @@ stripPrefix :: (Vec v a, Eq (v a))             => v a      -- ^ the prefix to be tested             -> v a -> Maybe (v a)-{-# INLINE stripPrefix #-}+{-# INLINABLE stripPrefix #-} stripPrefix v1@(Vec _ _ l1) v2@(Vec arr s l2)    | v1 `isPrefixOf` v2 = Just (Vec arr (s+l1) (l2-l1))    | otherwise = Nothing@@ -348,7 +358,7 @@ isPrefixOf :: forall v a. (Vec v a, Eq (v a))            => v a       -- ^ the prefix to be tested            -> v a -> Bool-{-# INLINE isPrefixOf #-}+{-# INLINABLE isPrefixOf #-} isPrefixOf (Vec arrA sA lA) (Vec arrB sB lB)     | lA == 0 = True     | lA > lB = False@@ -364,7 +374,7 @@ -- >>> commonPrefix "veeble" "fetzer" -- ("","veeble","fetzer") commonPrefix :: (Vec v a, Eq a) => v a -> v a -> (v a, v a, v a)-{-# INLINE commonPrefix #-}+{-# INLINABLE commonPrefix #-} commonPrefix vA@(Vec arrA sA lA) vB@(Vec arrB sB lB) = go sA sB   where     !endA = sA + lA@@ -380,7 +390,7 @@  -- | O(n) The 'stripSuffix' function takes two vectors and returns Just the remainder of the second iff the first is its suffix, and otherwise Nothing. stripSuffix :: (Vec v a, Eq (v a)) => v a -> v a -> Maybe (v a)-{-# INLINE stripSuffix #-}+{-# INLINABLE stripSuffix #-} stripSuffix v1@(Vec _ _ l1) v2@(Vec arr s l2)    | v1 `isSuffixOf` v2 = Just (Vec arr s (l2-l1))    | otherwise = Nothing@@ -388,7 +398,7 @@ -- | /O(n)/ The 'isSuffixOf' function takes two vectors and returns 'True' -- if the first is a suffix of the second. isSuffixOf :: forall v a. (Vec v a, Eq (v a)) => v a -> v a -> Bool-{-# INLINE isSuffixOf #-}+{-# INLINABLE isSuffixOf #-} isSuffixOf (Vec arrA sA lA) (Vec arrB sB lB)     | lA == 0 = True     | lA > lB = False@@ -398,7 +408,7 @@ -- -- @needle `isInfixOf` haystack === null haystack || indices needle haystake /= []@. isInfixOf :: (Vec v a, Eq a) => v a -> v a -> Bool-{-# INLINE isInfixOf #-}+{-# INLINABLE isInfixOf #-} isInfixOf needle = \ haystack -> null haystack || search haystack False /= []   where search = indices needle @@ -417,7 +427,7 @@ -- NOTE, this function behavior different with bytestring's. see -- <https://github.com/haskell/bytestring/issues/56 #56>. split :: (Vec v a, Eq a) => a -> v a -> [v a]-{-# INLINE split #-}+{-# INLINABLE split #-} split x = splitWith (==x)  -- | /O(m+n)/ Break haystack into pieces separated by needle.@@ -441,7 +451,7 @@ -- > intercalate s . splitOn s         == id -- > splitOn (singleton c)             == split (==c) splitOn :: (Vec v a, Eq a) => v a -> v a -> [v a]-{-# INLINE splitOn #-}+{-# INLINABLE splitOn #-} splitOn needle = splitBySearch   where     splitBySearch haystack@(Vec arr s l) = go s (search haystack False)@@ -464,7 +474,7 @@ -- NOTE, this function behavior different with bytestring's. see -- <https://github.com/haskell/bytestring/issues/56 #56>. splitWith :: Vec v a => (a -> Bool) -> v a -> [v a]-{-# INLINE splitWith #-}+{-# INLINABLE splitWith #-} splitWith f = go   where     go v@(Vec _ _ l)@@ -477,7 +487,7 @@  -- | /O(n)/ Breaks a 'Bytes' up into a list of words, delimited by ascii space. words ::  Bytes -> [Bytes]-{-# INLINE words #-}+{-# INLINABLE words #-} words (Vec arr s l) = go s s   where     !end = s + l@@ -498,7 +508,7 @@ -- --  Note that it __does not__ regard CR (@'\\r'@) as a newline character. lines ::  Bytes -> [Bytes]-{-# INLINE lines #-}+{-# INLINABLE lines #-} lines v     | null v = []     | otherwise = case elemIndex 10 v of@@ -507,19 +517,19 @@  -- | /O(n)/ Joins words with ascii space. unwords :: [Bytes] -> Bytes-{-# INLINE unwords #-}+{-# INLINABLE unwords #-} unwords = intercalateElem 32  -- | /O(n)/ Joins lines with ascii @\n@. -- -- NOTE: This functions is different from 'Prelude.unlines', it DOES NOT add a trailing @\n@. unlines :: [Bytes] -> Bytes-{-# INLINE unlines #-}+{-# INLINABLE unlines #-} unlines = intercalateElem 10  -- | Add padding to the left so that the whole vector's length is at least n. padLeft :: Vec v a => Int -> a -> v a -> v a-{-# INLINE padLeft #-}+{-# INLINABLE padLeft #-} padLeft n x v@(Vec arr s l) | n <= l = v                             | otherwise = create n (\ marr -> do                                     setArr marr 0 (n-l) x@@ -527,7 +537,7 @@  -- | Add padding to the right so that the whole vector's length is at least n. padRight :: Vec v a => Int -> a -> v a -> v a-{-# INLINE padRight #-}+{-# INLINABLE padRight #-} padRight n x v@(Vec arr s l) | n <= l = v                              | otherwise = create n (\ marr -> do                                     copyArr marr 0 arr s l@@ -539,7 +549,7 @@ -- | /O(n)/ 'reverse' @vs@ efficiently returns the elements of @xs@ in reverse order. -- reverse :: forall v a. (Vec v a) => v a -> v a-{-# INLINE reverse #-}+{-# INLINABLE reverse #-} reverse (Vec arr s l) = create l (go s (l-1))   where     go :: Int -> Int -> MArr (IArray v) s a -> ST s ()@@ -560,7 +570,7 @@ -- Lists. -- intersperse :: forall v a. Vec v a => a -> v a -> v a-{-# INLINE[1] intersperse #-}+{-# INLINE [1] intersperse #-} {-# RULES "intersperse/Bytes" intersperse = intersperseBytes #-} intersperse x v@(Vec arr s l) | l <= 1 = v                               | otherwise = create (2*l-1) (go s 0)@@ -589,7 +599,7 @@  -- | /O(n)/ Special 'intersperse' for 'Bytes' using SIMD intersperseBytes :: Word8 -> Bytes -> Bytes-{-# INLINE intersperseBytes #-}+{-# INLINABLE intersperseBytes #-} intersperseBytes c v@(PrimVector (PrimArray ba#) offset l)     | l <= 1 = v     | otherwise = unsafeDupablePerformIO $ do@@ -606,13 +616,13 @@ -- Note: 'intercalate' will force the entire vector list. -- intercalate :: Vec v a => v a -> [v a] -> v a-{-# INLINE intercalate #-}+{-# INLINABLE intercalate #-} intercalate s = concat . List.intersperse s  -- | /O(n)/ An efficient way to join vector with an element. -- intercalateElem :: forall v a. Vec v a => a -> [v a] -> v a-{-# INLINE intercalateElem #-}+{-# INLINABLE intercalateElem #-} intercalateElem _ [] = empty intercalateElem _ [v] = v intercalateElem w vs = create (len vs 0) (go 0 vs)@@ -633,7 +643,7 @@ -- vector argument. -- transpose :: Vec v a => [v a] -> [v a]-{-# INLINE transpose #-}+{-# INLINABLE transpose #-} transpose vs =     List.map (packN n) . List.transpose . List.map unpack $ vs   where n = List.length vs@@ -647,7 +657,7 @@ -- a vector of corresponding sums, the result will be evaluated strictly. zipWith' :: forall v a u b w c. (Vec v a, Vec u b, Vec w c)          => (a -> b -> c) -> v a -> u b -> w c-{-# INLINE zipWith' #-}+{-# INLINABLE zipWith' #-} zipWith' f (Vec arrA sA lA) (Vec arrB sB lB) = create len (go 0)   where     !len = min lA lB@@ -664,7 +674,7 @@ -- The results inside tuple will be evaluated strictly. unzipWith' :: forall v a u b w c. (Vec v a, Vec u b, Vec w c)            => (a -> (b, c)) -> v a -> (u b, w c)-{-# INLINE unzipWith' #-}+{-# INLINABLE unzipWith' #-} unzipWith' f (Vec arr s l) = createN2 l l (go 0)   where     go :: forall s. Int -> MArr (IArray u) s b -> MArr (IArray w) s c -> ST s (Int, Int)@@ -689,7 +699,7 @@ -- > lastM (scanl' f z xs) == Just (foldl f z xs). -- scanl' :: forall v u a b. (Vec v a, Vec u b) => (b -> a -> b) -> b -> v a -> u b-{-# INLINE scanl' #-}+{-# INLINABLE scanl' #-} scanl' f z (Vec arr s l) =     create (l+1) (\ marr -> writeArr marr 0 z >> go z s 1 marr)   where@@ -708,7 +718,7 @@ -- > scanl1' f [] == [] -- scanl1' :: forall v a. Vec v a => (a -> a -> a) -> v a -> v a-{-# INLINE scanl1' #-}+{-# INLINABLE scanl1' #-} scanl1' f (Vec arr s l)     | l <= 0    = empty     | otherwise = case indexArr' arr s of@@ -717,7 +727,7 @@ -- | scanr' is the right-to-left dual of scanl'. -- scanr' :: forall v u a b. (Vec v a, Vec u b) => (a -> b -> b) -> b -> v a -> u b-{-# INLINE scanr' #-}+{-# INLINABLE scanr' #-} scanr' f z (Vec arr s l) =     create (l+1) (\ marr -> writeArr marr l z >> go z (s+l-1) (l-1) marr)   where@@ -732,7 +742,7 @@  -- | 'scanr1'' is a variant of 'scanr' that has no starting value argument. scanr1' :: forall v a. Vec v a => (a -> a -> a) -> v a -> v a-{-# INLINE scanr1' #-}+{-# INLINABLE scanr1' #-} scanr1' f (Vec arr s l)     | l <= 0    = empty     | otherwise = case indexArr' arr (s+l-1) of@@ -743,7 +753,7 @@  -- | @x' = rangeCut x min max@ limit @x'@ 's range to @min@ ~ @max@. rangeCut :: Int -> Int -> Int -> Int-{-# INLINE rangeCut #-}+{-# INLINABLE rangeCut #-} rangeCut !r !min' !max' | r < min' = min'                         | r > max' = max'                         | otherwise = r

@@ -126,27 +126,27 @@  -- | /O(1)/ empty flat map. empty :: FlatIntMap v-{-# INLINE empty #-}+{-# NOINLINE empty #-} empty = FlatIntMap V.empty  -- | /O(N*logN)/ Pack list of key values, on key duplication prefer left one. pack :: [V.IPair v] -> FlatIntMap v-{-# INLINE pack #-}+{-# INLINABLE pack #-} pack kvs = FlatIntMap (V.mergeDupAdjacentLeft ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.pack kvs)))  -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer left one. packN :: Int -> [V.IPair v] -> FlatIntMap v-{-# INLINE packN #-}+{-# INLINABLE packN #-} packN n kvs = FlatIntMap (V.mergeDupAdjacentLeft ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.packN n kvs)))  -- | /O(N*logN)/ Pack list of key values, on key duplication prefer right one. packR :: [V.IPair v] -> FlatIntMap v-{-# INLINE packR #-}+{-# INLINABLE packR #-} packR kvs = FlatIntMap (V.mergeDupAdjacentRight ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.pack kvs)))  -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer right one. packRN :: Int -> [V.IPair v] -> FlatIntMap v-{-# INLINE packRN #-}+{-# INLINABLE packRN #-} packRN n kvs = FlatIntMap (V.mergeDupAdjacentRight ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.packN n kvs)))  -- | /O(N)/ Unpack key value pairs to a list sorted by keys in ascending order.@@ -165,12 +165,12 @@  -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer left one. packVector :: V.Vector (V.IPair v) -> FlatIntMap v-{-# INLINE packVector #-}+{-# INLINABLE packVector #-} packVector kvs = FlatIntMap (V.mergeDupAdjacentLeft ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) kvs))  -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer right one. packVectorR :: V.Vector (V.IPair v) -> FlatIntMap v-{-# INLINE packVectorR #-}+{-# INLINABLE packVectorR #-} packVectorR kvs = FlatIntMap (V.mergeDupAdjacentRight ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) kvs))  -- | /O(logN)/ Binary search on flat map.@@ -193,7 +193,7 @@  -- | /O(N)/ Insert new key value into map, replace old one if key exists. insert :: Int -> v -> FlatIntMap v -> FlatIntMap v-{-# INLINE insert #-}+{-# INLINABLE insert #-} insert k v (FlatIntMap vec) =     case binarySearch vec k of         Left i -> FlatIntMap (V.unsafeInsertIndex vec i (V.IPair k v))@@ -201,7 +201,7 @@  -- | /O(N)/ Delete a key value pair by key. delete :: Int -> FlatIntMap v -> FlatIntMap v-{-# INLINE delete #-}+{-# INLINABLE delete #-} delete k m@(FlatIntMap vec) =     case binarySearch vec k of         Left _  -> m@@ -211,7 +211,7 @@ -- -- The value is evaluated to WHNF before writing into map. adjust' :: (v -> v) -> Int -> FlatIntMap v -> FlatIntMap v-{-# INLINE adjust' #-}+{-# INLINABLE adjust' #-} adjust' f k m@(FlatIntMap vec) =     case binarySearch vec k of         Left _  -> m@@ -318,7 +318,7 @@ -- function also has access to the key associated with a value. traverseWithKey :: Applicative t => (Int -> a -> t b) -> FlatIntMap a -> t (FlatIntMap b) {-# INLINE traverseWithKey #-}-traverseWithKey f (FlatIntMap vs) = FlatIntMap <$> traverse (\ (V.IPair k v) -> V.IPair k <$> f k v) vs+traverseWithKey f (FlatIntMap vs) = FlatIntMap <$> V.traverse (\ (V.IPair k v) -> V.IPair k <$> f k v) vs  -------------------------------------------------------------------------------- 

@@ -91,27 +91,27 @@  -- | /O(1)/ empty flat set. empty :: FlatIntSet-{-# INLINE empty #-}+{-# NOINLINE empty #-} empty = FlatIntSet V.empty  -- | /O(N*logN)/ Pack list of values, on duplication prefer left one. pack :: [Int] -> FlatIntSet-{-# INLINE pack #-}+{-# INLINABLE pack #-} pack vs = FlatIntSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.pack vs)))  -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer left one. packN :: Int -> [Int] -> FlatIntSet-{-# INLINE packN #-}+{-# INLINABLE packN #-} packN n vs = FlatIntSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.packN n vs)))  -- | /O(N*logN)/ Pack list of values, on duplication prefer right one. packR :: [Int] -> FlatIntSet-{-# INLINE packR #-}+{-# INLINABLE packR #-} packR vs = FlatIntSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.pack vs)))  -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer right one. packRN :: Int -> [Int] -> FlatIntSet-{-# INLINE packRN #-}+{-# INLINABLE packRN #-} packRN n vs = FlatIntSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.packN n vs)))  -- | /O(N)/ Unpack a set of values to a list s in ascending order.@@ -130,23 +130,23 @@  -- | /O(N*logN)/ Pack vector of values, on duplication prefer left one. packVector :: V.PrimVector Int -> FlatIntSet-{-# INLINE packVector #-}+{-# INLINABLE packVector #-} packVector vs = FlatIntSet (V.mergeDupAdjacentLeft (==) (V.mergeSort vs))  -- | /O(N*logN)/ Pack vector of values, on duplication prefer right one. packVectorR :: V.PrimVector Int -> FlatIntSet-{-# INLINE packVectorR #-}+{-# INLINABLE packVectorR #-} packVectorR vs = FlatIntSet (V.mergeDupAdjacentRight (==) (V.mergeSort vs))  -- | /O(logN)/ Binary search on flat set. elem :: Int -> FlatIntSet -> Bool-{-# INLINE elem #-}+{-# INLINABLE elem #-} elem v (FlatIntSet vec) = case binarySearch vec v of Left _ -> False                                                      _      -> True  -- | /O(N)/ Insert new value into set. insert :: Int -> FlatIntSet -> FlatIntSet-{-# INLINE insert #-}+{-# INLINABLE insert #-} insert v m@(FlatIntSet vec) =     case binarySearch vec v of         Left i -> FlatIntSet (V.unsafeInsertIndex vec i v)@@ -154,7 +154,7 @@  -- | /O(N)/ Delete a value. delete :: Int -> FlatIntSet -> FlatIntSet-{-# INLINE delete #-}+{-# INLINABLE delete #-} delete v m@(FlatIntSet vec) =     case binarySearch vec v of         Left _ -> m

@@ -126,27 +126,27 @@  -- | /O(1)/ empty flat map. empty :: FlatMap k v-{-# INLINE empty #-}+{-# NOINLINE empty #-} empty = FlatMap V.empty  -- | /O(N*logN)/ Pack list of key values, on key duplication prefer left one. pack :: Ord k => [(k, v)] -> FlatMap k v-{-# INLINE pack #-}+{-# INLINABLE pack #-} pack kvs = FlatMap (V.mergeDupAdjacentLeft ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.pack kvs)))  -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer left one. packN :: Ord k => Int -> [(k, v)] -> FlatMap k v-{-# INLINE packN #-}+{-# INLINABLE packN #-} packN n kvs = FlatMap (V.mergeDupAdjacentLeft ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.packN n kvs)))  -- | /O(N*logN)/ Pack list of key values, on key duplication prefer right one. packR :: Ord k => [(k, v)] -> FlatMap k v-{-# INLINE packR #-}+{-# INLINABLE packR #-} packR kvs = FlatMap (V.mergeDupAdjacentRight ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.pack kvs)))  -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer right one. packRN :: Ord k => Int -> [(k, v)] -> FlatMap k v-{-# INLINE packRN #-}+{-# INLINABLE packRN #-} packRN n kvs = FlatMap (V.mergeDupAdjacentRight ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.packN n kvs)))  -- | /O(N)/ Unpack key value pairs to a list sorted by keys in ascending order.@@ -165,12 +165,12 @@  -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer left one. packVector :: Ord k => V.Vector (k, v) -> FlatMap k v-{-# INLINE packVector #-}+{-# INLINABLE packVector #-} packVector kvs = FlatMap (V.mergeDupAdjacentLeft ((==) `on` fst) (V.mergeSortBy (compare `on` fst) kvs))  -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer right one. packVectorR :: Ord k => V.Vector (k, v) -> FlatMap k v-{-# INLINE packVectorR #-}+{-# INLINABLE packVectorR #-} packVectorR kvs = FlatMap (V.mergeDupAdjacentRight ((==) `on` fst) (V.mergeSortBy (compare `on` fst) kvs))  -- | /O(logN)/ Binary search on flat map.@@ -193,7 +193,7 @@  -- | /O(N)/ Insert new key value into map, replace old one if key exists. insert :: Ord k => k -> v -> FlatMap k v -> FlatMap k v-{-# INLINE insert #-}+{-# INLINABLE insert #-} insert k v (FlatMap vec) =     case binarySearch vec k of         Left i -> FlatMap (V.unsafeInsertIndex vec i (k, v))@@ -201,7 +201,7 @@  -- | /O(N)/ Delete a key value pair by key. delete :: Ord k => k -> FlatMap k v -> FlatMap k v-{-# INLINE delete #-}+{-# INLINABLE delete #-} delete k m@(FlatMap vec) =     case binarySearch vec k of         Left _ -> m@@ -211,7 +211,7 @@ -- -- The value is evaluated to WHNF before writing into map. adjust' :: Ord k => (v -> v) -> k -> FlatMap k v -> FlatMap k v-{-# INLINE adjust' #-}+{-# INLINABLE adjust' #-} adjust' f k m@(FlatMap vec) =     case binarySearch vec k of         Left _ -> m@@ -319,7 +319,7 @@ -- function also has access to the key associated with a value. traverseWithKey :: Applicative t => (k -> a -> t b) -> FlatMap k a -> t (FlatMap k b) {-# INLINE traverseWithKey #-}-traverseWithKey f (FlatMap vs) = FlatMap <$> traverse (\ (k,v) -> (k,) <$> f k v) vs+traverseWithKey f (FlatMap vs) = FlatMap <$> V.traverse (\ (k,v) -> (k,) <$> f k v) vs  -------------------------------------------------------------------------------- 

@@ -91,27 +91,27 @@  -- | /O(1)/ empty flat set. empty :: FlatSet v-{-# INLINE empty #-}+{-# NOINLINE empty #-} empty = FlatSet V.empty  -- | /O(N*logN)/ Pack list of values, on duplication prefer left one. pack :: Ord v => [v] -> FlatSet v-{-# INLINE pack #-}+{-# INLINABLE pack #-} pack vs = FlatSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.pack vs)))  -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer left one. packN :: Ord v => Int -> [v] -> FlatSet v-{-# INLINE packN #-}+{-# INLINABLE packN #-} packN n vs = FlatSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.packN n vs)))  -- | /O(N*logN)/ Pack list of values, on duplication prefer right one. packR :: Ord v => [v] -> FlatSet v-{-# INLINE packR #-}+{-# INLINABLE packR #-} packR vs = FlatSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.pack vs)))  -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer right one. packRN :: Ord v => Int -> [v] -> FlatSet v-{-# INLINE packRN #-}+{-# INLINABLE packRN #-} packRN n vs = FlatSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.packN n vs)))  -- | /O(N)/ Unpack a set of values to a list s in ascending order.@@ -130,22 +130,22 @@  -- | /O(N*logN)/ Pack vector of values, on duplication prefer left one. packVector :: Ord v => V.Vector v -> FlatSet v-{-# INLINE packVector #-}+{-# INLINABLE packVector #-} packVector vs = FlatSet (V.mergeDupAdjacentLeft (==) (V.mergeSort vs))  -- | /O(N*logN)/ Pack vector of values, on duplication prefer right one. packVectorR :: Ord v => V.Vector v -> FlatSet v-{-# INLINE packVectorR #-}+{-# INLINABLE packVectorR #-} packVectorR vs = FlatSet (V.mergeDupAdjacentRight (==) (V.mergeSort vs))  -- | /O(logN)/ Binary search on flat set. elem :: Ord v => v -> FlatSet v -> Bool-{-# INLINE elem #-}+{-# INLINABLE elem #-} elem v (FlatSet vec) = case binarySearch vec v of Left _ -> False                                                   _      -> True -- | /O(N)/ Insert new value into set. insert :: Ord v => v -> FlatSet v -> FlatSet v-{-# INLINE insert #-}+{-# INLINABLE insert #-} insert v m@(FlatSet vec) =     case binarySearch vec v of         Left i -> FlatSet (V.unsafeInsertIndex vec i v)@@ -153,7 +153,7 @@  -- | /O(N)/ Delete a value from set. delete :: Ord v => v -> FlatSet v -> FlatSet v-{-# INLINE delete #-}+{-# INLINABLE delete #-} delete v m@(FlatSet vec) =     case binarySearch vec v of         Left _ -> m

@@ -66,7 +66,7 @@ -- | Encode 'V.Bytes' using hex(base16) encoding. hexEncode :: Bool   -- ^ uppercase?           -> V.Bytes -> V.Bytes-{-# INLINE hexEncode #-}+{-# INLINABLE hexEncode #-} hexEncode upper (V.PrimVector arr s l) = fst . unsafeDupablePerformIO $ do     allocPrimVectorUnsafe (l `unsafeShiftL` 1) $ \ buf# ->         withPrimArrayUnsafe arr $ \ parr _ ->@@ -88,7 +88,7 @@ -- | Text version of 'hexEncode'. hexEncodeText :: Bool   -- ^ uppercase?               -> V.Bytes -> T.Text-{-# INLINE hexEncodeText #-}+{-# INLINABLE hexEncodeText #-} hexEncodeText upper = T.Text . hexEncode upper  -- | Decode a hex encoding string, return Nothing on illegal bytes or incomplete input.@@ -134,14 +134,14 @@  -- | Decode a hex encoding string, throw 'HexDecodeException' on error. hexDecode' :: HasCallStack => V.Bytes -> V.Bytes-{-# INLINABLE hexDecode' #-}+{-# INLINE hexDecode' #-} hexDecode' ba = case hexDecode ba of     Just r -> r     _ -> throw (IllegalHexBytes ba callStack)  -- | Decode a hex encoding string, ignore ASCII whitespace(space, tab, newline, vertical tab, form feed, carriage return), throw 'HexDecodeException' on error. hexDecodeWS' :: HasCallStack => V.Bytes -> V.Bytes-{-# INLINABLE hexDecodeWS' #-}+{-# INLINE hexDecodeWS' #-} hexDecodeWS' ba = case hexDecodeWS ba of     Just r -> r     _ -> throw (IllegalHexBytes ba callStack)

@@ -78,7 +78,7 @@  -- | /O(n)/ Special 'elemIndices' for 'Bytes' using @memchr(3)@ elemIndicesBytes :: Word8 -> Bytes -> [Int]-{-# INLINE elemIndicesBytes #-}+{-# INLINABLE elemIndicesBytes #-} elemIndicesBytes w (PrimVector (PrimArray ba#) s l) = go s   where     !end = s + l@@ -91,12 +91,12 @@  -- | @findIndex f v = fst (find f v)@ findIndex :: Vec v a => (a -> Bool) -> v a -> Int-{-# INLINE findIndex #-}+{-# INLINABLE findIndex #-} findIndex f v = fst (find f v)  -- | @findIndexR f v = fst (findR f v)@ findIndexR :: Vec v a => (a -> Bool) -> v a -> Int-{-# INLINE findIndexR #-}+{-# INLINABLE findIndexR #-} findIndexR f v = fst (findR f v)  -- | /O(n)/ find the first index and element matching the predicate in a vector@@ -116,7 +116,7 @@  -- | /O(n)/ Special 'findByte' for 'Word8' using @memchr(3)@ findByte :: Word8 -> Bytes -> (Int, Maybe Word8)-{-# INLINE findByte #-}+{-# INLINABLE findByte #-} findByte w (PrimVector (PrimArray ba#) s l) =     case c_memchr ba# s w l of         -1 -> (l, Nothing)@@ -138,7 +138,7 @@  -- | /O(n)/ Special 'findR' for 'Bytes' with @memrchr@. findByteR :: Word8 -> Bytes -> (Int, Maybe Word8)-{-# INLINE findByteR #-}+{-# INLINABLE findByteR #-} findByteR w (PrimVector (PrimArray ba#) s l) =     case c_memrchr ba# s w l of         -1 -> (-1, Nothing)@@ -148,7 +148,7 @@ -- returns a vector containing those elements that satisfy the -- predicate. filter :: forall v a. Vec v a => (a -> Bool) -> v a -> v a-{-# INLINE filter #-}+{-# INLINABLE filter #-} filter g (Vec arr s l)     | l == 0    = empty     | otherwise = createN l (go g 0 s)@@ -167,7 +167,7 @@ -- -- > partition p vs == (filter p vs, filter (not . p) vs) partition :: forall v a. Vec v a => (a -> Bool) -> v a -> (v a, v a)-{-# INLINE partition #-}+{-# INLINABLE partition #-} partition g (Vec arr s l)     | l == 0    = (empty, empty)     | otherwise = createN2 l l (go g 0 0 s)@@ -211,7 +211,7 @@         -> v a -- ^ vector to search in (@haystack@)         -> Bool -- ^ report partial match at the end of haystack         -> [Int]-{-# INLINABLE[1] indicesOverlapping #-}+{-# INLINE [1] indicesOverlapping #-} {-# RULES "indicesOverlapping/Bytes" indicesOverlapping = indicesOverlappingBytes #-} indicesOverlapping needle@(Vec narr noff nlen) = search   where@@ -321,7 +321,7 @@ -- -- > indicesOverlapping "" "abc" = [0,1,2] indices :: (Vec v a, Eq a) => v a -> v a -> Bool -> [Int]-{-# INLINABLE[1] indices #-}+{-# INLINE [1] indices #-} {-# RULES "indices/Bytes" indices = indicesBytes #-} indices needle@(Vec narr noff nlen) = search   where@@ -407,7 +407,7 @@ -- is found, check if @next[j] == -1@, if so next search continue with @needle[0]@ -- and @haystack[i+1]@, otherwise continue with @needle[next[j]]@ and @haystack[i]@. kmpNextTable :: (Vec v a, Eq a) => v a -> PrimArray Int-{-# INLINE kmpNextTable #-}+{-# INLINABLE kmpNextTable #-} kmpNextTable (Vec arr s l) = runST (do     ma <- newArr (l+1)     writeArr ma 0 (-1)@@ -438,7 +438,7 @@ -- This's particularly suitable for search UTF-8 bytes since the significant bits -- of a beginning byte is usually the same. sundayBloom :: Bytes -> Word64-{-# INLINE sundayBloom #-}+{-# INLINABLE sundayBloom #-} sundayBloom (Vec arr s l) = go 0x00000000 s   where     !end = s+l@@ -452,5 +452,5 @@ -- | O(1) Test if a bloom filter contain a certain 'Word8'. -- elemSundayBloom :: Word64 -> Word8 -> Bool-{-# INLINE elemSundayBloom #-}+{-# INLINABLE elemSundayBloom #-} elemSundayBloom b w = b .&. (0x01 `unsafeShiftL` (fromIntegral w .&. 0x3f)) /= 0

@@ -76,7 +76,7 @@ mergeSort = mergeSortBy compare  mergeSortBy :: forall v a. Vec v a => (a -> a -> Ordering) -> v a -> v a-{-# INLINE mergeSortBy #-}+{-# INLINABLE mergeSortBy #-} mergeSortBy cmp vec@(Vec _ _ l)     | l <= mergeTileSize = insertSortBy cmp vec     | otherwise = runST (do@@ -139,7 +139,7 @@  -- | The mergesort tile size, @mergeTileSize = 8@. mergeTileSize :: Int-{-# INLINE mergeTileSize #-}+{-# INLINABLE mergeTileSize #-} mergeTileSize = 8  -- | /O(n^2)/ Sort vector based on element's 'Ord' instance with simple@@ -148,11 +148,11 @@ -- This is a stable sort. O(n) extra space are needed, -- which will be freezed into result vector. insertSort :: (Vec v a, Ord a) => v a -> v a-{-# INLINE insertSort #-}+{-# INLINABLE insertSort #-} insertSort = insertSortBy compare  insertSortBy :: Vec v a => (a -> a -> Ordering) -> v a -> v a-{-# INLINE insertSortBy #-}+{-# INLINABLE insertSortBy #-} insertSortBy cmp v@(Vec _ _ l) | l <= 1 = v                                | otherwise = create l (insertSortToMArr cmp v 0) @@ -162,7 +162,7 @@                   -> Int            -- writing offset in the mutable array                   -> MArr (IArray v) s a   -- writing mutable array, must have enough space!                   -> ST s ()-{-# INLINE insertSortToMArr #-}+{-# INLINABLE insertSortToMArr #-} insertSortToMArr cmp (Vec arr s l) moff marr = go s   where     !end = s + l@@ -457,7 +457,7 @@ -- -- Use this function on a sorted vector will have the same effects as 'nub'. mergeDupAdjacent :: forall v a. (Vec v a, Eq a) => v a -> v a-{-# INLINE mergeDupAdjacent #-}+{-# INLINABLE mergeDupAdjacent #-} mergeDupAdjacent = mergeDupAdjacentBy (==) const  -- | Merge duplicated adjacent element, prefer left element.@@ -466,14 +466,14 @@                      -> v a                      -> v a mergeDupAdjacentLeft eq = mergeDupAdjacentBy eq const-{-# INLINE mergeDupAdjacentLeft #-}+{-# INLINABLE mergeDupAdjacentLeft #-}  -- | Merge duplicated adjacent element, prefer right element. mergeDupAdjacentRight :: forall v a. Vec v a                       => (a -> a -> Bool)  -- ^ equality tester, @\ left right -> eq left right@                       -> v a                       -> v a-{-# INLINE mergeDupAdjacentRight #-}+{-# INLINABLE mergeDupAdjacentRight #-} mergeDupAdjacentRight eq = mergeDupAdjacentBy eq (\ _ x -> x)  -- | Merge duplicated adjacent element, based on a equality tester and a merger function.

@@ -93,6 +93,7 @@   , module Foreign.C.Types   , module Data.Primitive.Ptr   , module Z.Data.Array.Unaligned+  , withMutablePrimArrayContents, withPrimArrayContents   -- ** Internal helpers   , hs_std_string_size   , hs_copy_std_string@@ -111,7 +112,7 @@ import           Foreign.C.Types import           GHC.Ptr import           GHC.Exts-import           Z.Data.Array+import           Z.Data.Array.Base             (withMutablePrimArrayContents, withPrimArrayContents) import           Z.Data.Array.Unaligned import           Z.Data.Array.UnliftedArray import           Z.Data.Vector.Base@@ -183,6 +184,7 @@ clearMBA :: MBA# a          -> Int  -- ^ in bytes          -> IO ()+{-# INLINE clearMBA #-} clearMBA mba# len = do     let mba = (MutableByteArray mba#)     setByteArray mba 0 len (0 :: Word8)@@ -209,6 +211,7 @@ -- -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. withPrimArrayListUnsafe :: [PrimArray a] -> (BAArray# a -> Int -> IO b) -> IO b+{-# INLINE withPrimArrayListUnsafe #-} withPrimArrayListUnsafe pas f = do     let l = List.length pas     mla <- unsafeNewUnliftedArray l@@ -301,7 +304,7 @@ -- -- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>. withPrimArraySafe :: (Prim a) => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b-{-# INLINE withPrimArraySafe #-}+{-# INLINABLE withPrimArraySafe #-} withPrimArraySafe arr f     | isPrimArrayPinned arr = do         let siz = sizeofPrimArray arr@@ -340,7 +343,7 @@                     => Int      -- ^ in elements                     -> (Ptr a -> IO b)                     -> IO (PrimArray a, b)-{-# INLINE allocPrimArraySafe #-}+{-# INLINABLE allocPrimArraySafe #-} allocPrimArraySafe len f = do     mpa <- newAlignedPinnedPrimArray len     !r <- withMutablePrimArrayContents mpa f@@ -354,7 +357,7 @@ -- -- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>. withPrimVectorSafe :: forall a b. Prim a => PrimVector a -> (Ptr a -> Int -> IO b) -> IO b-{-# INLINE withPrimVectorSafe #-}+{-# INLINABLE withPrimVectorSafe #-} withPrimVectorSafe (PrimVector arr s l) f     | isPrimArrayPinned arr =         withPrimArrayContents arr $ \ ptr ->@@ -370,7 +373,7 @@ -- -- Don't pass a forever loop to this function, see <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>. withPrimSafe :: forall a b. Prim a => a -> (Ptr a -> IO b) -> IO (a, b)-{-# INLINE withPrimSafe #-}+{-# INLINABLE withPrimSafe #-} withPrimSafe v f = do     buf <- newAlignedPinnedPrimArray 1     writePrimArray buf 0 v@@ -380,7 +383,7 @@  -- | like 'withPrimSafe', but don't write initial value. allocPrimSafe :: forall a b. Prim a => (Ptr a -> IO b) -> IO (a, b)-{-# INLINE allocPrimSafe #-}+{-# INLINABLE allocPrimSafe #-} allocPrimSafe f = do     buf <- newAlignedPinnedPrimArray 1     !b <- withMutablePrimArrayContents buf $ \ ptr -> f ptr@@ -391,7 +394,7 @@ allocPrimVectorSafe :: forall a b . Prim a                     => Int      -- ^ in elements                     -> (Ptr a -> IO b) -> IO (PrimVector a, b)-{-# INLINE allocPrimVectorSafe #-}+{-# INLINABLE allocPrimVectorSafe #-} allocPrimVectorSafe len f = do     mpa <- newAlignedPinnedPrimArray len     !r <- withMutablePrimArrayContents mpa f@@ -402,12 +405,12 @@ -- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimVector'. allocBytesSafe :: Int      -- ^ in bytes                -> (Ptr Word8 -> IO b) -> IO (Bytes, b)-{-# INLINE allocBytesSafe #-}+{-# INLINABLE allocBytesSafe #-} allocBytesSafe = allocPrimVectorSafe  -- | Convert a 'PrimArray' to a pinned one(memory won't moved by GC) if necessary. pinPrimArray :: Prim a => PrimArray a -> IO (PrimArray a)-{-# INLINE pinPrimArray #-}+{-# INLINABLE pinPrimArray #-} pinPrimArray arr     | isPrimArrayPinned arr = return arr     | otherwise = do@@ -419,7 +422,7 @@  -- | Convert a 'PrimVector' to a pinned one(memory won't moved by GC) if necessary. pinPrimVector :: Prim a => PrimVector a -> IO (PrimVector a)-{-# INLINE pinPrimVector #-}+{-# INLINABLE pinPrimVector #-} pinPrimVector v@(PrimVector pa s l)     | isPrimArrayPinned pa = return v     | otherwise = do@@ -438,7 +441,7 @@ -- should be given in bytes. -- clearPtr :: Ptr a -> Int -> IO ()-{-# INLINE clearPtr #-}+{-# INLINABLE clearPtr #-} clearPtr dest nbytes = memset dest 0 (fromIntegral nbytes)  -- | Copy some bytes from a null terminated pointer(without copying the null terminator).@@ -447,7 +450,7 @@ -- This method is provided if you really need to read 'Bytes', there's no encoding guarantee, -- result could be any bytes sequence. fromNullTerminated :: Ptr a -> IO Bytes-{-# INLINE fromNullTerminated #-}+{-# INLINABLE fromNullTerminated #-} fromNullTerminated (Ptr addr#) = do     len <- fromIntegral <$> c_strlen addr#     marr <- newPrimArray len@@ -460,7 +463,7 @@ -- There's no encoding guarantee, result could be any bytes sequence. fromPtr :: Ptr a -> Int -- ^ in bytes         -> IO Bytes-{-# INLINE fromPtr #-}+{-# INLINABLE fromPtr #-} fromPtr (Ptr addr#) len = do     marr <- newPrimArray len     copyPtrToMutablePrimArray marr 0 (Ptr addr#) len@@ -473,7 +476,7 @@ fromPrimPtr :: forall a. Prim a             => Ptr a -> Int -- ^  in elements             -> IO (PrimVector a)-{-# INLINE fromPrimPtr #-}+{-# INLINABLE fromPrimPtr #-} fromPrimPtr (Ptr addr#) len = do     marr <- newPrimArray len     copyPtrToMutablePrimArray marr 0 (Ptr addr#) len@@ -486,6 +489,7 @@ -- | Run FFI in bracket and marshall @std::string*@ result into Haskell heap bytes, -- memory pointed by @std::string*@ will be @delete@ ed. fromStdString :: IO (Ptr StdString) -> IO Bytes+{-# INLINABLE fromStdString #-} fromStdString f = bracket f hs_delete_std_string     (\ q -> do         siz <- hs_std_string_size q@@ -498,9 +502,11 @@  -- | O(n), Convert from 'ByteString'. fromByteString :: ByteString -> Bytes+{-# INLINABLE fromByteString #-} fromByteString bs = case toShort bs of     (SBS ba#) -> PrimVector (PrimArray ba#) 0 (B.length bs)  -- | O(n), Convert tp 'ByteString'. toByteString :: Bytes -> ByteString+{-# INLINABLE toByteString #-} toByteString (PrimVector (PrimArray ba#) s l) = B.unsafeTake l . B.unsafeDrop s . fromShort $ SBS ba#

@@ -28,7 +28,7 @@ import GHC.Ptr import GHC.Exts import GHC.IO-import Z.Data.Array+import Z.Data.Array                         hiding (newPinnedPrimArray) import Z.Foreign  -- | Lightweight foreign pointers.

@@ -18,21 +18,22 @@ import           Test.Hspec import           Test.Hspec.QuickCheck import           Data.Time.LocalTime+import           Data.Time.Calendar  spec :: Spec spec = describe "builder time" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do-    describe "utcTime === format" $ do         prop "utcTime === format" $ \ t ->             (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" t) === (T.unpack . B.buildText $ B.utcTime t) -    describe "localTime === format" $ do         prop "localTime === format" $ \ t ->             (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" t) === (T.unpack . B.buildText $ B.localTime t) -    describe "zonedTime === format" $ do         prop "zonedTime === format" $ \ t0 z0 ->             let z = abs z0 `div` 1440                 t = ZonedTime t0 (minutesToTimeZone z)             in if z == 0                 then (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" t) === (T.unpack . B.buildText $ B.zonedTime t)                 else (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" t) === (T.unpack . B.buildText $ B.zonedTime t)++        modifyMaxSuccess (*100) . modifyMaxSize (*100) . prop "toGregorianInt64 === toGregorian" $ \ mjd ->+            B.toGregorian' mjd == toGregorian mjd

@@ -57,13 +57,13 @@                     (w:_) | f w  -> Just (V.pack (L.dropWhile f s), V.pack (L.takeWhile f s))                     _            -> Nothing -        prop "take" $ \ s n ->+        prop "take" $ \ s (Positive n) ->             parse'' (P.take n) s ===                 if L.length s >= n                     then Just (V.pack (L.drop n s), V.pack (L.take n s))                     else Nothing -        prop "skip" $ \ s n ->+        prop "skip" $ \ s (Positive  n) ->             parse'' (P.skip n) s ===                 if L.length s >= n                     then Just (V.pack (L.drop n s), ())

@@ -10,6 +10,7 @@ import           Data.Time.Format import qualified Z.Data.Builder           as B import qualified Z.Data.Parser            as P+import qualified Z.Data.Parser.Time       as P import qualified Z.Data.Text as T import           Test.QuickCheck import           Test.QuickCheck.Function@@ -18,19 +19,20 @@ import           Test.Hspec import           Test.Hspec.QuickCheck import           Data.Time.LocalTime+import           Data.Time.Calendar  spec :: Spec spec = describe "parser time" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do-    describe "utcTime roundtrip" $ do         prop "utcTime roundtrip" $ \ t ->             Right t === (P.parse' P.utcTime . B.build $ B.utcTime t) -    describe "localTime roundtrip" $ do         prop "localTime roundtrip" $ \ t ->             Right t === (P.parse' P.localTime . B.build $ B.localTime t) -    describe "zonedTime roundtrip" $ do         prop "zonedTime roundtrip" $ \ t0 z0 ->             let z = abs z0 `div` 1440                 t = ZonedTime t0 (minutesToTimeZone z)             in (zonedTimeToUTC <$> Right t) === (zonedTimeToUTC <$> (P.parse' P.zonedTime . B.build $ B.zonedTime t))++        modifyMaxSuccess (*100) . modifyMaxSize (*100) . prop "fromGregorianValidInt64 == fromGregorianValid" $ \ y m d ->+            P.fromGregorianValid' y m d == fromGregorianValid y m d

@@ -154,6 +154,14 @@         prop "vector concat === List.concat" $ \ xss ->             (V.concat . List.map (V.pack @V.PrimVector @Word8) $ xss) === (V.pack . List.concat $ xss) +    describe "vector concatR == List.concat . List.reverse" $ do+        prop "vector concatR === List.concat" $ \ xss ->+            (V.concatR . List.map (V.pack @V.Vector @Integer) $ xss)  === (V.pack . List.concat . List.reverse $ xss)+        prop "vector concatR === List.concat" $ \ xss ->+            (V.concatR . List.map (V.pack @V.PrimVector @Int) $ xss) === (V.pack . List.concat . List.reverse $ xss)+        prop "vector concatR === List.concat" $ \ xss ->+            (V.concatR . List.map (V.pack @V.PrimVector @Word8) $ xss) === (V.pack . List.concat . List.reverse $ xss)+     describe "vector concatMap == List.concatMap" $ do         prop "vector concatMap === List.concatMap" $ \ xss (Fun _ f) ->             (V.concatMap (V.pack @V.Vector @Integer . f) . V.pack $ xss)  === (V.pack . List.concatMap f $ xss)