foundation 0.0.9 → 0.0.10

raw patch · 90 files changed

+2779/−1245 lines, 90 filesdep ~Win32PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Win32

API changes (from Hackage documentation)

Files

• CHANGELOG.md +130/−0
• Foundation.hs +2/−2
• Foundation/Array/Bitmap.hs +35/−38
• Foundation/Array/Boxed.hs +87/−78
• Foundation/Array/Chunked/Unboxed.hs +43/−43
• Foundation/Array/Internal.hs +1/−1
• Foundation/Array/Unboxed.hs +282/−148
• Foundation/Array/Unboxed/ByteArray.hs +1/−1
• Foundation/Array/Unboxed/Mutable.hs +61/−23
• Foundation/Boot/Builder.hs +2/−2
• Foundation/Check.hs +48/−323
• Foundation/Check/Arbitrary.hs +3/−0
• Foundation/Check/Config.hs +95/−0
• Foundation/Check/Gen.hs +1/−0
• Foundation/Check/Main.hs +287/−0
• Foundation/Check/Print.hs +82/−0
• Foundation/Check/Property.hs +12/−5
• Foundation/Check/Types.hs +86/−0
• Foundation/Class/Storable.hs +8/−8
• Foundation/Collection/Buildable.hs +1/−1
• Foundation/Collection/Collection.hs +6/−3
• Foundation/Collection/Indexed.hs +6/−6
• Foundation/Collection/Mappable.hs +2/−2
• Foundation/Collection/Mutable.hs +4/−5
• Foundation/Collection/Sequential.hs +37/−17
• Foundation/Conduit/Textual.hs +18/−0
• Foundation/Foreign/Alloc.hs +11/−0
• Foundation/Hashing/FNV.hs +8/−8
• Foundation/Hashing/SipHash.hs +6/−4
• Foundation/IO/File.hs +8/−8
• Foundation/IO/FileMap.hs +2/−2
• Foundation/IO/Terminal.hs +9/−0
• Foundation/Internal/PrimTypes.hs +3/−3
• Foundation/Math/Trigonometry.hs +0/−1
• Foundation/Network/IPv6.hs +13/−9
• Foundation/Numerical/Additive.hs +36/−11
• Foundation/Numerical/Number.hs +5/−0
• Foundation/Parser.hs +4/−3
• Foundation/Primitive/Block.hs +34/−41
• Foundation/Primitive/Block/Base.hs +90/−46
• Foundation/Primitive/Block/Mutable.hs +15/−6
• Foundation/Primitive/Exception.hs +7/−7
• Foundation/Primitive/Imports.hs +1/−1
• Foundation/Primitive/IntegralConv.hs +20/−0
• Foundation/Primitive/NormalForm.hs +1/−1
• Foundation/Primitive/Runtime.hs +1/−1
• Foundation/Primitive/Types.hs +78/−41
• Foundation/Primitive/Types/OffsetSize.hs +127/−53
• Foundation/Primitive/Types/Ptr.hs +40/−0
• Foundation/Primitive/UTF8/Base.hs +2/−2
• Foundation/Primitive/UTF8/Helper.hs +13/−13
• Foundation/Random.hs +5/−5
• Foundation/String/ASCII.hs +18/−25
• Foundation/String/Encoding/Encoding.hs +2/−2
• Foundation/String/ModifiedUTF8.hs +3/−3
• Foundation/String/UTF8.hs +147/−92
• Foundation/System/Bindings.hs +1/−0
• Foundation/System/Bindings/Hs.hs +17/−0
• Foundation/System/Bindings/Linux.hsc +1/−2
• Foundation/System/Bindings/Macos.hsc +21/−0
• Foundation/System/Bindings/Network.hsc +1/−0
• Foundation/System/Bindings/Posix.hsc +1/−1
• Foundation/System/Bindings/PosixDef.hsc +1/−1
• Foundation/System/Bindings/Time.hsc +114/−0
• Foundation/System/Bindings/Windows.hs +1/−0
• Foundation/System/Entropy.hs +2/−2
• Foundation/Time/Bindings.hs +30/−0
• Foundation/Time/StopWatch.hs +113/−0
• Foundation/Time/Types.hs +44/−0
• Foundation/Timing.hs +68/−0
• Foundation/Timing/Main.hs +64/−0
• LICENSE +2/−1
• README.md +1/−0
• benchs/Main.hs +3/−3
• benchs/Sys.hs +3/−3
• cbits/foundation_mem.c +6/−0
• cbits/foundation_random.c +2/−2
• cbits/foundation_system.h +6/−0
• cbits/foundation_time.c +84/−0
• foundation.cabal +101/−85
• tests/Checks.hs +3/−0
• tests/Test/Data/Network.hs +4/−4
• tests/Test/Foundation/Array.hs +2/−2
• tests/Test/Foundation/ChunkedUArray.hs +2/−2
• tests/Test/Foundation/Collection.hs +3/−3
• tests/Test/Foundation/Random.hs +20/−30
• tests/Test/Foundation/Storable.hs +3/−3
• tests/Test/Foundation/String.hs +1/−1
• tests/Test/Utils/Foreign.hs +2/−2
• tests/Tests.hs +3/−4

@@ -0,0 +1,130 @@+## 0.0.10++* Cleanup collection APIs that take a lone Int (length, take, drop, splitAt, ..) to take a CountOf+* Rename Size to CountOf+* Add basic time functions+* Add os dependent timing capability+* Add simple pattern matching for test names with checks.+* add '--list-tests' for checks+* Optimise Eq and Ord for blocks and uarray++## 0.0.9++* Introduce Block & MutableBlock which represent a chunk of memory without slices+  and are faster/leaner in many cases.+* Cleanup String code and some primitives boundaries+* Fix storable alignment tests+* Add These data type (either a, b or both)+* Implement checks command line+* Improve checks terminal output+* drop support for GHC 7.4 and GHC 7.6+* Improve performance of copy out of block and uarray++## 0.0.8++* Add MonadReader and MonadState+* Improve performance of numerical read parsers (integral, double)+* Improve precision of double read parser+* Add Textual conduit combinator (fromBytes, toBytes, lines)+* Add DList+* Fix building on latest Win32, RHEL 5.8+* Add NormalForm+* Export some functions in Internal module to manipulate unboxed mutable array++## 0.0.7++* Improve Checks: random seed, new properties and improved printing+* Add ability to parse Natural, Integer, and Double from String+* Temporarily remove compilation of experimental network resolution introduced in 0.0.5 for windows building.+* Cleanup Offset and Size fixing some bug in String module++## 0.0.6++* Fix build on Centos 6.x / older linux distribution+* Improve test checks generators++## 0.0.5++* Generalize monadic map (mapM, mapM\_)+* HostName type+* Network address / name resolution+* Fix compilation on FreeBSD & OpenBSD+* Initial re-implementation for property tests and tests orchestration+* Fix bug in splitElem, and breakElem+* Improve splitOn to return empty elements+* Fix API bug for snoc and cons in Chunked UArray+* Add UUID+* Check API+* Fix compilation on !x86++## 0.0.4++* Add Conduit for all your streaming needs+* Expose Sequential from Foundation+* Export internal withPtr for optimisation+* Export `ifThenElse`+* Use the proper `String` type for error instead of `[Char]`+* Add `any` and `all` to `Collection`+* Add defaulting to Integer and Double for numerical types+* Add negation for Double and Float (and their associated C types)+* Add/Export system bindings (Posix file/memory handling, Linux Inotify)+* Add Big Endian (BE) / Little Endian (LE) wrapping types+* Add a way to transform an UArray into Hexadecimal/Base16+* Add IPv4 and IPv6 types++## 0.0.3++Monad:++* Add MonadCatch and MonadThrow classes+* Add Transformer base class (MonadTrans)+* Add IdentityT, StateT, ReaderT++Build:++* Fix build on !x86++## 0.0.2++Classes:++* Add `Bifunctor`+* Implement Better storable type class (#111)+* Expose Nthable for GHC >= 7.10 (product type getter)+* Split basic function from `Sequential` to `Collection`+* show return a Foundation `String` now instead of `[Char]`++Numerical:+* Overhaul of numerical classes (`Integral`, `Rational`, `Divisible`, ..)+* add IntegralRounding (i.e. rounding from floating types)+* Expose IEEE manipulation stuff+* Expose all trigonometry functions in `Foundation.Math.Trigonometry`+* Export `Natural` (Unsigned `Integer`)++Collection:+* Add partition+* Add isPrefixOf and isSuffixOf+* Add ArrayBuilder machinery+* Add `String` parser+* Add minimum and maximum to Collection.+* Export Foldable and Collection in Foundation+* add head,last,tail,init++Types:+* Basic `ArrayUArray` support (Array of unboxed Array)+* Add instance for `Float` and `Double` for numerical+* Boxed array: add native slicing in the type+* add `NonEmpty` type+* Add some Data declaration for based type++Hashing:+* Hashing: add FNV, SipHash hash functions family+* Hashable: add support to hash types++Random support:+* Add support for system entropy+* Add pseudo random generation capability using a ChaCha core.++## 0.0.1++* Initial version

@@ -85,7 +85,7 @@     , Prelude.Rational     , Prelude.Float     , Prelude.Double-    , Size(..), Offset(..)+    , CountOf(..), Offset(..)       -- ** Collection types     , UArray     , PrimType@@ -171,7 +171,7 @@ import           Foundation.Tuple  import qualified Foundation.Class.Bifunctor-import           Foundation.Primitive.Types.OffsetSize (Size(..), Offset(..))+import           Foundation.Primitive.Types.OffsetSize (CountOf(..), Offset(..)) import qualified Foundation.Primitive import           Foundation.Primitive.Show import           Foundation.Internal.NumLiteral

@@ -43,9 +43,9 @@ import           GHC.ST import qualified Data.List -data Bitmap = Bitmap (Size Bool) (UArray Word32)+data Bitmap = Bitmap (CountOf Bool) (UArray Word32) -data MutableBitmap st = MutableBitmap (Size Bool) (MUArray Word32 st)+data MutableBitmap st = MutableBitmap (CountOf Bool) (MUArray Word32 st)  bitsPerTy :: Int bitsPerTy = 32@@ -114,11 +114,11 @@  instance C.IndexedCollection Bitmap where     (!) l n-        | isOutOfBound n (lengthSize l) = Nothing+        | isOutOfBound n (length l) = Nothing         | otherwise                     = Just $ index l n     findIndex predicate c = loop 0       where-        !len = lengthSize c+        !len = length c         loop i             | i .==# len                  = Nothing             | predicate (unsafeIndex c i) = Just i@@ -134,7 +134,7 @@     unsafeThaw = unsafeThaw     unsafeFreeze = unsafeFreeze -    mutNew n = new (Size n)+    mutNew = new     mutUnsafeWrite = unsafeWrite     mutUnsafeRead = unsafeRead     mutWrite = write@@ -215,14 +215,14 @@     | isOutOfBound n len = primOutOfBound OOB_Write n len     | otherwise          = unsafeWrite mb n val   where-    len = mutableLengthSize mb+    len = mutableLength mb {-# INLINE write #-}  read :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> prim Bool read mb n     | isOutOfBound n len = primOutOfBound OOB_Read n len     | otherwise        = unsafeRead mb n-  where len = mutableLengthSize mb+  where len = mutableLength mb {-# INLINE read #-}  -- | Return the element at a specific index from a Bitmap.@@ -232,7 +232,7 @@ index bits n     | isOutOfBound n len = outOfBound OOB_Index n len     | otherwise          = unsafeIndex bits n-  where len = lengthSize bits+  where len = length bits {-# INLINE index #-}  -- | Return the element at a specific index from an array without bounds checking.@@ -249,29 +249,26 @@ ----------------------------------------------------------------------- -- higher level collection implementation ------------------------------------------------------------------------length :: Bitmap -> Int-length (Bitmap (Size len) _) = len--lengthSize :: Bitmap -> Size Bool-lengthSize (Bitmap sz _) = sz+length :: Bitmap -> CountOf Bool+length (Bitmap sz _) = sz -mutableLengthSize :: MutableBitmap st -> Size Bool-mutableLengthSize (MutableBitmap sz _) = sz+mutableLength :: MutableBitmap st -> CountOf Bool+mutableLength (MutableBitmap sz _) = sz  empty :: Bitmap empty = Bitmap 0 A.empty -new :: PrimMonad prim => Size Bool -> prim (MutableBitmap (PrimState prim))-new sz@(Size len) =+new :: PrimMonad prim => CountOf Bool -> prim (MutableBitmap (PrimState prim))+new sz@(CountOf len) =     MutableBitmap sz <$> A.new nbElements   where-    nbElements :: Size Word32-    nbElements = Size ((len `alignRoundUp` bitsPerTy) .>>. shiftPerTy)+    nbElements :: CountOf Word32+    nbElements = CountOf ((len `alignRoundUp` bitsPerTy) .>>. shiftPerTy)  -- | make an array from a list of elements. vFromList :: [Bool] -> Bitmap vFromList allBools = runST $ do-    mbitmap <- new (Size len)+    mbitmap <- new len     loop mbitmap 0 allBools   where     loop mb _ []     = unsafeFreeze mb@@ -299,7 +296,7 @@ -- | transform an array to a list. vToList :: Bitmap -> [Bool] vToList a = loop 0-  where len = lengthSize a+  where len = length a         loop i | i .==# len  = []                | otherwise = unsafeIndex a i : loop (i+1) @@ -309,8 +306,8 @@     | la /= lb  = False     | otherwise = loop 0   where-    !la = lengthSize a-    !lb = lengthSize b+    !la = length a+    !lb = length b     loop n | n .==# la = True            | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1) @@ -318,8 +315,8 @@ vCompare :: Bitmap -> Bitmap -> Ordering vCompare a b = loop 0   where-    !la = lengthSize a-    !lb = lengthSize b+    !la = length a+    !lb = length b     loop n         | n .==# la = if la == lb then EQ else LT         | n .==# lb = GT@@ -341,21 +338,21 @@ null :: Bitmap -> Bool null (Bitmap nbBits _) = nbBits == 0 -take :: Int -> Bitmap -> Bitmap-take nbElems bits@(Bitmap (Size nbBits) ba)+take :: CountOf Bool -> Bitmap -> Bitmap+take nbElems bits@(Bitmap nbBits ba)     | nbElems <= 0      = empty     | nbElems >= nbBits = bits-    | otherwise         = Bitmap (Size nbElems) ba -- TODO : although it work right now, take on the underlaying ba too+    | otherwise         = Bitmap nbElems ba -- TODO : although it work right now, take on the underlaying ba too -drop :: Int -> Bitmap -> Bitmap-drop nbElems bits@(Bitmap (Size nbBits) _)+drop :: CountOf Bool -> Bitmap -> Bitmap+drop nbElems bits@(Bitmap nbBits _)     | nbElems <= 0      = bits     | nbElems >= nbBits = empty     | otherwise         = unoptimised (C.drop nbElems) bits         -- TODO: decide if we have drop easy by having a bit offset in the data structure         -- or if we need to shift stuff around making all the indexing slighlty more complicated -splitAt :: Int -> Bitmap -> (Bitmap, Bitmap)+splitAt :: CountOf Bool -> Bitmap -> (Bitmap, Bitmap) splitAt n v = (take n v, drop n v)  -- unoptimised@@ -366,12 +363,12 @@ break :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) break predicate v = findBreak 0   where-    len = lengthSize v-    findBreak i@(Offset i')+    len = length v+    findBreak i         | i .==# len = (v, empty)         | otherwise  =             if predicate (unsafeIndex v i)-                then splitAt i' v+                then splitAt (offsetAsSize i) v                 else findBreak (i+1)  span :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap)@@ -403,7 +400,7 @@ find :: (Bool -> Bool) -> Bitmap -> Maybe Bool find predicate vec = loop 0   where-    !len = lengthSize vec+    !len = length vec     loop i         | i .==# len = Nothing         | otherwise  =@@ -422,7 +419,7 @@ foldl :: (a -> Bool -> a) -> a -> Bitmap -> a foldl f initialAcc vec = loop 0 initialAcc   where-    len = lengthSize vec+    len = length vec     loop i acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -430,7 +427,7 @@ foldr :: (Bool -> a -> a) -> a -> Bitmap -> a foldr f initialAcc vec = loop 0   where-    len = lengthSize vec+    len = length vec     loop i         | i .==# len = initialAcc         | otherwise  = unsafeIndex vec i `f` loop (i+1)@@ -441,7 +438,7 @@ foldl' :: (a -> Bool -> a) -> a -> Bitmap -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    len = lengthSize vec+    len = length vec     loop i !acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))

@@ -16,9 +16,7 @@     , MArray     , empty     , length-    , lengthSize     , mutableLength-    , mutableLengthSize     , copy     , unsafeCopyAtRO     , thaw@@ -54,6 +52,7 @@     , sortBy     , filter     , reverse+    , elem     , find     , foldl'     , foldr@@ -72,16 +71,14 @@ import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Types import           Foundation.Primitive.NormalForm-import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Monad import           Foundation.Primitive.Exception import           Foundation.Boot.Builder import qualified Foundation.Boot.List as List-import qualified Prelude  -- | Array of a data Array a = Array {-# UNPACK #-} !(Offset a)-                     {-# UNPACK #-} !(Size a)+                     {-# UNPACK #-} !(CountOf a)                                     (Array# a)     deriving (Typeable) @@ -96,14 +93,14 @@ instance NormalForm a => NormalForm (Array a) where     toNormalForm arr = loop 0       where-        !sz = lengthSize arr+        !sz = length arr         loop !i             | i .==# sz = ()             | otherwise = unsafeIndex arr i `seq` loop (i+1)  -- | Mutable Array of a data MArray a st = MArray {-# UNPACK #-} !(Offset a)-                          {-# UNPACK #-} !(Size a)+                          {-# UNPACK #-} !(CountOf a)                                          (MutableArray# st a)     deriving (Typeable) @@ -130,11 +127,11 @@  -- | return the numbers of elements in a mutable array mutableLength :: MArray ty st -> Int-mutableLength (MArray _ (Size len) _) = len+mutableLength (MArray _ (CountOf len) _) = len {-# INLINE mutableLength #-}  -- | return the numbers of elements in a mutable array-mutableLengthSize :: MArray ty st -> Size ty+mutableLengthSize :: MArray ty st -> CountOf ty mutableLengthSize (MArray _ size _) = size {-# INLINE mutableLengthSize #-} @@ -145,7 +142,7 @@ index array n     | isOutOfBound n len = outOfBound OOB_Index n len     | otherwise          = unsafeIndex array n-  where len = lengthSize array+  where len = length array {-# INLINE index #-}  -- | Return the element at a specific index from an array without bounds checking.@@ -215,8 +212,8 @@ -- and every values is copied, before returning the mutable array. thaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim)) thaw array = do-    m <- new (lengthSize array)-    unsafeCopyAtRO m (Offset 0) array (Offset 0) (lengthSize array)+    m <- new (length array)+    unsafeCopyAtRO m (Offset 0) array (Offset 0) (length array)     return m {-# INLINE thaw #-} @@ -238,7 +235,7 @@        -> Offset ty                  -- ^ offset at destination        -> MArray ty (PrimState prim) -- ^ source array        -> Offset ty                  -- ^ offset at source-       -> Size ty                    -- ^ number of elements to copy+       -> CountOf ty                    -- ^ number of elements to copy        -> prim () copyAt dst od src os n = loop od os   where -- !endIndex = os `offsetPlusE` n@@ -256,23 +253,23 @@                -> Offset ty                  -- ^ offset at destination                -> Array ty                   -- ^ source array                -> Offset ty                  -- ^ offset at source-               -> Size ty                    -- ^ number of elements to copy+               -> CountOf ty                    -- ^ number of elements to copy                -> prim () unsafeCopyAtRO (MArray (Offset (I# dstart)) _ da) (Offset (I# dofs))                (Array  (Offset (I# sstart)) _ sa) (Offset (I# sofs))-               (Size (I# n)) =+               (CountOf (I# n)) =     primitive $ \st ->         (# copyArray# sa (sstart +# sofs) da (dstart +# dofs) n st, () #)  -- | Allocate a new array with a fill function that has access to the elements of --   the source array. unsafeCopyFrom :: Array ty -- ^ Source array-               -> Size ty  -- ^ Length of the destination array+               -> CountOf ty  -- ^ Length of the destination array                -> (Array ty -> Offset ty -> MArray ty s -> ST s ())                -- ^ Function called for each element in the source array                -> ST s (Array ty) -- ^ Returns the filled new array unsafeCopyFrom v' newLen f = new newLen >>= fill (Offset 0) f >>= unsafeFreeze-  where len = lengthSize v'+  where len = length v'         endIdx = Offset 0 `offsetPlusE` len         fill i f' r'             | i == endIdx = return r'@@ -285,14 +282,14 @@ -- -- All mutable arrays are allocated on a 64 bits aligned addresses -- and always contains a number of bytes multiples of 64 bits.-new :: PrimMonad prim => Size ty -> prim (MArray ty (PrimState prim))-new sz@(Size (I# n)) = primitive $ \s1 ->+new :: PrimMonad prim => CountOf ty -> prim (MArray ty (PrimState prim))+new sz@(CountOf (I# n)) = primitive $ \s1 ->     case newArray# n (error "vector: internal error uninitialized vector") s1 of         (# s2, ma #) -> (# s2, MArray (Offset 0) sz ma #)  -- | Create a new array of size @n by settings each cells through the -- function @f.-create :: forall ty . Size ty -- ^ the size of the array+create :: forall ty . CountOf ty -- ^ the size of the array        -> (Offset ty -> ty)   -- ^ the function that set the value at the index        -> Array ty            -- ^ the array created create n initializer = runST (new n >>= iter initializer)@@ -310,9 +307,9 @@ -- higher level collection implementation ----------------------------------------------------------------------- equal :: Eq a => Array a -> Array a -> Bool-equal a b = (len == lengthSize b) && eachEqual 0+equal a b = (len == length b) && eachEqual 0   where-    len = lengthSize a+    len = length a     eachEqual !i         | i .==# len                         = True         | unsafeIndex a i /= unsafeIndex b i = False@@ -321,8 +318,8 @@ vCompare :: Ord a => Array a -> Array a -> Ordering vCompare a b = loop 0   where-    !la = lengthSize a-    !lb = lengthSize b+    !la = length a+    !lb = length b     loop n         | n .==# la = if la == lb then EQ else LT         | n .==# lb = GT@@ -334,16 +331,13 @@ empty :: Array a empty = runST $ onNewArray 0 (\_ s -> s) -length :: Array a -> Int-length (Array _ (Size len) _) = len--lengthSize :: Array a -> Size a-lengthSize (Array _ sz _) = sz+length :: Array a -> CountOf a+length (Array _ sz _) = sz  vFromList :: [a] -> Array a vFromList l = runST (new len >>= loop 0 l)   where-    len = Size $ List.length l+    len = CountOf $ List.length l     loop _ []     ma = unsafeFreeze ma     loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma @@ -351,7 +345,7 @@ vToList v     | len == 0  = []     | otherwise = fmap (unsafeIndex v) [0..sizeLastOffset len]-  where !len = lengthSize v+  where !len = length v  -- | Append 2 arrays together by creating a new bigger array append :: Array ty -> Array ty -> Array ty@@ -360,19 +354,19 @@     unsafeCopyAtRO r (Offset 0) a (Offset 0) la     unsafeCopyAtRO r (sizeAsOffset la) b (Offset 0) lb     unsafeFreeze r-  where la = lengthSize a-        lb = lengthSize b+  where la = length a+        lb = length b  concat :: [Array ty] -> Array ty concat l = runST $ do-    r <- new (Size $ Prelude.sum $ fmap length l)+    r <- new (mconcat $ fmap length l)     loop r (Offset 0) l     unsafeFreeze r   where loop _ _ []     = return ()         loop r i (x:xs) = do             unsafeCopyAtRO r i x (Offset 0) lx             loop r (i `offsetPlusE` lx) xs-          where lx = lengthSize x+          where lx = length x  {- modify :: PrimMonad m@@ -399,7 +393,7 @@     case newArray# len# (error "onArray") st of { (# st2, mv #) ->     case f mv st2                            of { st3           ->     case unsafeFreezeArray# mv st3           of { (# st4, a #)  ->-        (# st4, Array (Offset 0) (Size len) a #) }}}+        (# st4, Array (Offset 0) (CountOf len) a #) }}}  ----------------------------------------------------------------------- @@ -407,47 +401,53 @@ null :: Array ty -> Bool null = (==) 0 . length -take ::  Int -> Array ty -> Array ty+take :: CountOf ty -> Array ty -> Array ty take nbElems a@(Array start len arr)     | nbElems <= 0 = empty     | n == len     = a     | otherwise    = Array start n arr   where-    n = min (Size nbElems) len+    n = min nbElems len -drop ::  Int -> Array ty -> Array ty+drop :: CountOf ty -> Array ty -> Array ty drop nbElems a@(Array start len arr)     | nbElems <= 0 = a     | n == len     = empty     | otherwise    = Array (start `offsetPlusE` n) (len - n) arr   where-    n = min (Size nbElems) len+    n = min nbElems len -splitAt ::  Int -> Array ty -> (Array ty, Array ty)+splitAt :: CountOf ty -> Array ty -> (Array ty, Array ty) splitAt nbElems a@(Array start len arr)     | nbElems <= 0 = (empty, a)     | n == len     = (a, empty)     | otherwise    =         (Array start n arr, Array (start `offsetPlusE` n) (len - n) arr)   where-    n = min (Size nbElems) len+    n = min nbElems len -revTake :: Int -> Array ty -> Array ty-revTake nbElems v = drop (length v - nbElems) v+-- inverse a CountOf that is specified from the end (e.g. take n elements from the end)+countFromStart :: Array ty -> CountOf ty -> CountOf ty+countFromStart v sz@(CountOf sz')+    | sz >= len = CountOf 0+    | otherwise = CountOf (len' - sz')+  where len@(CountOf len') = length v -revDrop :: Int -> Array ty -> Array ty-revDrop nbElems v = take (length v - nbElems) v+revTake :: CountOf ty -> Array ty -> Array ty+revTake n v = drop (countFromStart v n) v -revSplitAt :: Int -> Array ty -> (Array ty, Array ty)-revSplitAt n v = (drop idx v, take idx v)-  where idx = length v - n+revDrop :: CountOf ty -> Array ty -> Array ty+revDrop n v = take (countFromStart v n) v +revSplitAt :: CountOf ty -> Array ty -> (Array ty, Array ty)+revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n+ splitOn ::  (ty -> Bool) -> Array ty -> [Array ty] splitOn predicate vec-    | len == Size 0 = [mempty]+    | len == CountOf 0 = [mempty]     | otherwise     = loop (Offset 0) (Offset 0)   where-    !len = lengthSize vec+    !len = length vec     !endIdx = Offset 0 `offsetPlusE` len     loop prevIdx idx         | idx == endIdx = [sub vec prevIdx idx]@@ -469,19 +469,19 @@ break ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty) break predicate v = findBreak 0   where-    !len = lengthSize v-    findBreak i@(Offset i')+    !len = length v+    findBreak i         | i .==# len  = (v, empty)         | otherwise   =             if predicate (unsafeIndex v i)-                then splitAt i' v+                then splitAt (offsetAsSize i) v                 else findBreak (i+1)  intersperse :: ty -> Array ty -> Array ty intersperse sep v-    | len <= Size 1 = v-    | otherwise     = runST $ unsafeCopyFrom v ((len + len) - Size 1) (go (Offset 0 `offsetPlusE` (len - Size 1)) sep)-  where len = lengthSize v+    | len <= CountOf 1 = v+    | otherwise     = runST $ unsafeCopyFrom v ((len + len) - CountOf 1) (go (Offset 0 `offsetPlusE` (len - CountOf 1)) sep)+  where len = length v         -- terminate 1 before the end          go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s ()@@ -498,7 +498,7 @@ span p = break (not . p)  map :: (a -> b) -> Array a -> Array b-map f a = create (sizeCast Proxy $ lengthSize a) (\i -> f $ unsafeIndex a (offsetCast Proxy i))+map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i))  {- mapIndex :: (Int -> a -> b) -> Array a -> Array b@@ -511,19 +511,19 @@     unsafeWrite a 0 e     unsafeFreeze a -replicate :: Word -> ty -> Array ty-replicate sz ty = create (Size (integralCast sz)) (const ty)+replicate :: CountOf ty -> ty -> Array ty+replicate sz ty = create sz (const ty)  cons :: ty -> Array ty -> Array ty cons e vec-    | len == Size 0 = singleton e+    | len == CountOf 0 = singleton e     | otherwise     = runST $ do-        mv <- new (len + Size 1)+        mv <- new (len + CountOf 1)         unsafeWrite mv 0 e         unsafeCopyAtRO mv (Offset 1) vec (Offset 0) len         unsafeFreeze mv   where-    !len = lengthSize vec+    !len = length vec  snoc ::  Array ty -> ty -> Array ty snoc vec e@@ -534,7 +534,7 @@         unsafeWrite mv (sizeAsOffset len) e         unsafeFreeze mv   where-    !len = lengthSize vec+    !len = length vec  uncons :: Array ty -> Maybe (ty, Array ty) uncons vec@@ -546,14 +546,23 @@ unsnoc :: Array ty -> Maybe (Array ty, ty) unsnoc vec     | len == 0  = Nothing-    | otherwise = Just (take (lenI - 1) vec, unsafeIndex vec (sizeLastOffset len))+    | otherwise = Just (take (len - 1) vec, unsafeIndex vec (sizeLastOffset len))   where-    !len@(Size lenI) = lengthSize vec+    !len = length vec -find ::  (ty -> Bool) -> Array ty -> Maybe ty+elem :: Eq ty => ty -> Array ty -> Bool+elem !ty arr = loop 0+  where+    !sz = length arr+    loop !i | i .==# sz = False+            | t == ty   = True+            | otherwise = loop (i+1)+      where t = unsafeIndex arr i++find :: (ty -> Bool) -> Array ty -> Maybe ty find predicate vec = loop 0   where-    !len = lengthSize vec+    !len = length vec     loop i         | i .==# len = Nothing         | otherwise  =@@ -565,7 +574,7 @@     | len == 0  = empty     | otherwise = runST (thaw vec >>= doSort xford)   where-    len = lengthSize vec+    len = length vec     doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty)     doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma       where@@ -600,7 +609,7 @@ filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec))   where-    !len = lengthSize vec+    !len = length vec     copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)     copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec       where@@ -617,19 +626,19 @@     copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d)     unsafeFreeze m -unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> Size ty -> prim (Array ty)+unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> CountOf ty -> prim (Array ty) unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma)  reverse :: Array ty -> Array ty reverse a = create len toEnd   where-    len@(Size s) = lengthSize a+    len@(CountOf s) = length a     toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i))  foldl :: (a -> ty -> a) -> a -> Array ty -> a foldl f initialAcc vec = loop 0 initialAcc   where-    len = lengthSize vec+    len = length vec     loop !i acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -637,7 +646,7 @@ foldr :: (ty -> a -> a) -> a -> Array ty -> a foldr f initialAcc vec = loop 0   where-    len = lengthSize vec+    len = length vec     loop !i         | i .==# len = initialAcc         | otherwise  = unsafeIndex vec i `f` loop (i+1)@@ -645,7 +654,7 @@ foldl' :: (a -> ty -> a) -> a -> Array ty -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    len = lengthSize vec+    len = length vec     loop !i !acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -670,16 +679,16 @@     | sizeChunksI <= 0 = builderBuild 64 ab     | otherwise        = do         first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks)         cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)         -- Build final array         let totalSize = prevChunksSize st + offsetAsSize i         new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze   where-    sizeChunks = Size sizeChunksI+    sizeChunks = CountOf sizeChunksI      fillFromEnd _   []     mua = return mua     fillFromEnd !end (x:xs) mua = do-        let sz = lengthSize x+        let sz = length x         unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz         fillFromEnd (end - sz) xs mua

@@ -12,6 +12,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} module Foundation.Array.Chunked.Unboxed     ( ChunkedUArray     ) where@@ -85,11 +86,11 @@  instance PrimType ty => C.IndexedCollection (ChunkedUArray ty) where     (!) l n-        | isOutOfBound n (lengthSize l) = Nothing+        | isOutOfBound n (length l) = Nothing         | otherwise                     = Just $ index l n     findIndex predicate c = loop 0       where-        !len = lengthSize c+        !len = length c         loop i             | i .==# len = Nothing             | otherwise  =@@ -114,25 +115,22 @@ null (ChunkedUArray array) =     C.null array || allNulls 0   where-    !len = A.lengthSize array+    !len = A.length array     allNulls !idx       | idx .==# len = True       | otherwise    = C.null (array `A.unsafeIndex` idx) && allNulls (idx + 1)  -- | Returns the length of this `ChunkedUArray`, by summing each inner length. -- Complexity: O(n) where `n` is the number of chunks, as U.length u is O(1).-length :: PrimType ty => ChunkedUArray ty -> Int-length (ChunkedUArray array) = C.foldl' (\acc l -> acc + C.length l) 0 array--lengthSize :: PrimType ty => ChunkedUArray ty -> Size ty-lengthSize (ChunkedUArray array) = C.foldl' (\acc l -> acc + U.lengthSize l) 0 array+length :: PrimType ty => ChunkedUArray ty -> CountOf ty+length (ChunkedUArray array) = C.foldl' (\acc l -> acc + U.length l) 0 array  -- | Returns `True` if the given element is contained in the `ChunkedUArray`. -- Complexity: O(n) where `n` is the number of chunks, as U.length u is O(1). elem :: PrimType ty => ty -> ChunkedUArray ty -> Bool elem el (ChunkedUArray array) = loop 0   where-    !len = A.lengthSize array+    !len = A.length array     loop i         | i .==# len = False         | otherwise  =@@ -156,71 +154,73 @@ equal ca1 ca2 =     len1 == len2 && go 0   where-    len1 = lengthSize ca1-    len2 = lengthSize ca2+    len1 = length ca1+    len2 = length ca2      go !x       | x .==# len1 = True       | otherwise   = (ca1 `unsafeIndex` x == ca2 `unsafeIndex` x) && go (x + 1) +-- given an offset express in element of ty, return the offset in array in the spine,+-- plus the relative offset in element on this array findPos :: PrimType ty => Offset ty -> ChunkedUArray ty -> Maybe (Offset (UArray ty), Offset ty) findPos absOfs (ChunkedUArray array)     | A.null array = Nothing     | otherwise    = loop absOfs 0   where-    !len = A.lengthSize array+    !len = A.length array     loop relOfs outerI         | outerI .==# len = Nothing -- haven't found what to do         | relOfs == 0     = Just (outerI, 0)         | otherwise       =             let !innera   = A.unsafeIndex array outerI-                !innerLen = U.lengthSize innera+                !innerLen = U.length innera              in case removeArraySize relOfs innerLen of                         Nothing      -> Just (outerI, relOfs)                         Just relOfs' -> loop relOfs' (outerI + 1)  splitChunk :: Offset (UArray ty) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty)-splitChunk (Offset ofs) (ChunkedUArray c) = (ChunkedUArray *** ChunkedUArray) $ A.splitAt ofs c+splitChunk ofs (ChunkedUArray c) = (ChunkedUArray *** ChunkedUArray) $ A.splitAt (offsetAsSize ofs) c -take :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+take :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty take n c@(ChunkedUArray spine)     | n <= 0    = empty     | otherwise =-        case findPos (Offset n) c of-            Nothing              -> c-            Just (Offset ofs, 0) -> ChunkedUArray (A.take ofs spine)-            Just (ofs@(Offset ofs'), (Offset r)) ->+        case findPos (sizeAsOffset n) c of+            Nothing       -> c+            Just (ofs, 0) -> ChunkedUArray (A.take (offsetAsSize ofs) spine)+            Just (ofs, r) ->                 let uarr = A.unsafeIndex spine ofs-                 in ChunkedUArray (A.take ofs' spine `A.snoc` U.take r uarr)+                 in ChunkedUArray (A.take (offsetAsSize ofs) spine `A.snoc` U.take (offsetAsSize r) uarr) -drop :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+drop :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty drop n c@(ChunkedUArray spine)     | n <= 0    = c     | otherwise =-        case findPos (Offset n) c of-            Nothing              -> empty-            Just (Offset ofs, 0) -> ChunkedUArray (A.drop ofs spine)-            Just (ofs@(Offset ofs'), (Offset r)) ->+        case findPos (sizeAsOffset n) c of+            Nothing       -> empty+            Just (ofs, 0) -> ChunkedUArray (A.drop (offsetAsSize ofs) spine)+            Just (ofs, r) ->                 let uarr = A.unsafeIndex spine ofs-                 in ChunkedUArray (U.drop r uarr `A.cons` A.drop (ofs'+1) spine)+                 in ChunkedUArray (U.drop (offsetAsSize r) uarr `A.cons` A.drop (offsetAsSize ofs+1) spine) -splitAt :: PrimType ty => Int -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty)+splitAt :: PrimType ty => CountOf ty -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) splitAt n c@(ChunkedUArray spine)     | n <= 0    = (empty, c)     | otherwise =-        case findPos (Offset n) c of+        case findPos (sizeAsOffset n) c of             Nothing       -> (c, empty)             Just (ofs, 0) -> splitChunk ofs c-            Just (ofs@(Offset ofs'), (Offset r)) ->+            Just (ofs, offsetAsSize -> r) ->                 let uarr = A.unsafeIndex spine ofs-                 in ( ChunkedUArray (A.take ofs' spine `A.snoc` U.take r uarr)-                    , ChunkedUArray (U.drop r uarr `A.cons` A.drop (ofs'+1) spine)+                 in ( ChunkedUArray (A.take (offsetAsSize ofs) spine `A.snoc` U.take r uarr)+                    , ChunkedUArray (U.drop r uarr `A.cons` A.drop (offsetAsSize ofs+1) spine)                     ) -revTake :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+revTake :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty revTake n c = drop (length c - n) c -revDrop :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+revDrop :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty revDrop n c = take (length c - n) c  -- TODO: Improve implementation.@@ -253,26 +253,26 @@  cons :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty cons el (ChunkedUArray inner) = ChunkedUArray $ runST $ do-  let newLen = (Size $ C.length inner + 1)+  let newLen = C.length inner + 1   newArray   <- A.new newLen   let single = fromList [el]   A.unsafeWrite newArray 0 single-  A.unsafeCopyAtRO newArray (Offset 1) inner (Offset 0) (Size $ C.length inner)+  A.unsafeCopyAtRO newArray (Offset 1) inner (Offset 0) (C.length inner)   A.unsafeFreeze newArray  snoc :: PrimType ty => ChunkedUArray ty -> ty -> ChunkedUArray ty snoc (ChunkedUArray spine) el = ChunkedUArray $ runST $ do-  newArray  <- A.new (A.lengthSize spine + 1)+  newArray  <- A.new (A.length spine + 1)   let single = U.singleton el-  A.unsafeCopyAtRO newArray (Offset 0) spine (Offset 0) (Size $ C.length spine)-  A.unsafeWrite newArray (sizeAsOffset $ A.lengthSize spine) single+  A.unsafeCopyAtRO newArray (Offset 0) spine (Offset 0) (C.length spine)+  A.unsafeWrite newArray (sizeAsOffset $ A.length spine) single   A.unsafeFreeze newArray  -- TODO optimise find :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> Maybe ty find fn v = loop 0   where-    len = lengthSize v+    len = length v     loop !idx       | idx .==# len = Nothing       | otherwise    =@@ -289,7 +289,7 @@ index array n     | isOutOfBound n len = outOfBound OOB_Index n len     | otherwise          = unsafeIndex array n-  where len = lengthSize array+  where len = length array {-# INLINE index #-}  unsafeIndex :: PrimType ty => ChunkedUArray ty -> Offset ty -> ty@@ -303,13 +303,13 @@       -- Skip empty chunks.       | C.null u  = go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i       | otherwise =-          case removeArraySize i (U.lengthSize u) of+          case removeArraySize i (U.length u) of               Just i' -> go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i'               Nothing -> U.unsafeIndex u i  {-# INLINE unsafeIndex #-} -removeArraySize :: Offset ty -> Size ty -> Maybe (Offset ty)-removeArraySize (Offset ty) (Size s)+removeArraySize :: Offset ty -> CountOf ty -> Maybe (Offset ty)+removeArraySize (Offset ty) (CountOf s)     | ty >= s   = Just (Offset (ty - s))     | otherwise = Nothing

@@ -25,4 +25,4 @@     ) where  import           Foundation.Array.Unboxed-import           Foundation.Array.Unboxed.Mutable+import           Foundation.Array.Unboxed.Mutable hiding (copyToPtr)

@@ -26,7 +26,6 @@     , recast     , unsafeRecast     , length-    , lengthSize     , freeze     , unsafeFreeze     , thaw@@ -36,6 +35,7 @@     , empty     , create     , createFromIO+    , createFromPtr     , sub     , copyToPtr     , withPtr@@ -52,6 +52,7 @@     , unsafeRead     , unsafeWrite     -- * Functions+    , equalMemcmp     , singleton     , replicate     , map@@ -60,6 +61,7 @@     , index     , null     , take+    , unsafeTake     , drop     , splitAt     , revDrop@@ -95,8 +97,10 @@ import           GHC.Word import           GHC.ST import           GHC.Ptr+import           GHC.IO (unsafeDupablePerformIO) import           GHC.ForeignPtr (ForeignPtr) import           Foreign.Marshal.Utils (copyBytes)+import           Foreign.C.Types (CInt, CSize) import qualified Prelude import           Foundation.Internal.Base import           Foundation.Internal.Primitive@@ -107,11 +111,11 @@ import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           Foundation.Primitive.NormalForm-import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.Utils import           Foundation.Primitive.Exception-import           Foundation.Array.Unboxed.Mutable hiding (sub)+import           Foundation.System.Bindings.Hs+import           Foundation.Array.Unboxed.Mutable hiding (sub, copyToPtr) import           Foundation.Numerical import           Foundation.Boot.Builder import qualified Data.List@@ -123,11 +127,11 @@ -- to foreign interface data UArray ty =       UVecBA {-# UNPACK #-} !(Offset ty)-             {-# UNPACK #-} !(Size ty)+             {-# UNPACK #-} !(CountOf ty)              {-# UNPACK #-} !PinnedStatus {- unpinned / pinned flag -}                             ByteArray#     | UVecAddr {-# UNPACK #-} !(Offset ty)-               {-# UNPACK #-} !(Size ty)+               {-# UNPACK #-} !(CountOf ty)                               !(FinalPtr ty)     deriving (Typeable) @@ -147,6 +151,7 @@ instance (PrimType ty, Eq ty) => Eq (UArray ty) where     (==) = equal instance (PrimType ty, Ord ty) => Ord (UArray ty) where+    {-# SPECIALIZE instance Ord (UArray Word8) #-}     compare = vCompare  instance PrimType ty => Monoid (UArray ty) where@@ -172,8 +177,8 @@ -- and every values is copied, before returning the mutable array. thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim)) thaw array = do-    ma <- new (lengthSize array)-    unsafeCopyAtRO ma azero array (Offset 0) (lengthSize array)+    ma <- new (length array)+    unsafeCopyAtRO ma azero array (Offset 0) (length array)     return ma {-# INLINE thaw #-} @@ -185,7 +190,7 @@     | isOutOfBound n len = outOfBound OOB_Index n len     | otherwise          = unsafeIndex array n   where-    !len = lengthSize array+    !len = length array {-# INLINE index #-}  -- | Return the element at a specific index from an array without bounds checking.@@ -202,8 +207,7 @@ unsafeIndexer (UVecAddr start _ fptr) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n)) {-# INLINE unsafeIndexer #-} -unsafeDewrap :: PrimType ty-             => (ByteArray# -> Offset ty -> a)+unsafeDewrap :: (ByteArray# -> Offset ty -> a)              -> (Ptr ty -> Offset ty -> ST s a)              -> UArray ty              -> a@@ -211,27 +215,36 @@ unsafeDewrap f _ (UVecBA start _ _ ba)   = f ba start {-# INLINE unsafeDewrap #-} +unsafeDewrap2 :: (ByteArray# -> Offset ty -> ByteArray# -> Offset ty -> a)+              -> (Ptr ty -> Offset ty -> Ptr ty -> Offset ty -> ST s a)+              -> (ByteArray# -> Offset ty -> Ptr ty -> Offset ty -> ST s a)+              -> (Ptr ty -> Offset ty -> ByteArray# -> Offset ty -> ST s a)+              -> UArray ty+              -> UArray ty+              -> a+unsafeDewrap2 f _ _ _ (UVecBA start1 _ _ ba1)   (UVecBA start2 _ _ ba2)   = f ba1 start1 ba2 start2+unsafeDewrap2 _ f _ _ (UVecAddr start1 _ fptr1) (UVecAddr start2 _ fptr2) = withUnsafeFinalPtr fptr1 $ \ptr1 ->+                                                                                  withFinalPtr fptr2 $ \ptr2 -> f ptr1 start1 ptr2 start2+unsafeDewrap2 _ _ f _ (UVecBA start1 _ _ ba1)   (UVecAddr start2 _ fptr2) = withUnsafeFinalPtr fptr2 $ \ptr2 -> f ba1 start1 ptr2 start2+unsafeDewrap2 _ _ _ f (UVecAddr start1 _ fptr1) (UVecBA start2 _ _ ba2)   = withUnsafeFinalPtr fptr1 $ \ptr1 -> f ptr1 start1 ba2 start2+{-# INLINE [2] unsafeDewrap2 #-}+ foreignMem :: PrimType ty            => FinalPtr ty -- ^ the start pointer with a finalizer-           -> Int         -- ^ the number of elements (in elements, not bytes)+           -> CountOf ty  -- ^ the number of elements (in elements, not bytes)            -> UArray ty-foreignMem fptr nb = UVecAddr (Offset 0) (Size nb) fptr+foreignMem fptr nb = UVecAddr (Offset 0) nb fptr  fromForeignPtr :: PrimType ty                => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements                -> UArray ty-fromForeignPtr (fptr, ofs, len)   = UVecAddr (Offset ofs) (Size len) (toFinalPtrForeign fptr)+fromForeignPtr (fptr, ofs, len)   = UVecAddr (Offset ofs) (CountOf len) (toFinalPtrForeign fptr) --- | return the number of elements of the array.-length :: PrimType ty => UArray ty -> Int-length a = let (Size len) = lengthSize a in len+length :: UArray ty -> CountOf ty+length (UVecAddr _ len _) = len+length (UVecBA _ len _ _) = len {-# INLINE[1] length #-} -lengthSize :: PrimType ty => UArray ty -> Size ty-lengthSize (UVecAddr _ len _) = len-lengthSize (UVecBA _ len _ _) = len-{-# INLINE[1] lengthSize #-}- -- TODO Optimise with copyByteArray# -- | Copy @n@ sequential elements from the specified offset in a source array --   to the specified position in a destination array.@@ -243,7 +256,7 @@                -> Offset ty                   -- ^ offset at destination                -> UArray ty                   -- ^ source array                -> Offset ty                   -- ^ offset at source-               -> Size ty                     -- ^ number of elements to copy+               -> CountOf ty                     -- ^ number of elements to copy                -> prim () unsafeCopyAtRO (MUVecMA dstStart _ _ dstMba) ed uvec@(UVecBA srcStart _ _ srcBa) es n =     primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #)@@ -251,7 +264,7 @@     sz = primSizeInBytes (vectorProxyTy uvec)     !(Offset (I# os))   = offsetOfE sz (srcStart+es)     !(Offset (I# od))   = offsetOfE sz (dstStart+ed)-    !(Size (I# nBytes)) = sizeOfE sz n+    !(CountOf (I# nBytes)) = sizeOfE sz n unsafeCopyAtRO (MUVecMA dstStart _ _ dstMba) ed uvec@(UVecAddr srcStart _ srcFptr) es n =     withFinalPtr srcFptr $ \srcPtr ->         let !(Ptr srcAddr) = srcPtr `plusPtr` os@@ -260,7 +273,7 @@     sz  = primSizeInBytes (vectorProxyTy uvec)     !(Offset os)        = offsetOfE sz (srcStart+es)     !(Offset (I# od))   = offsetOfE sz (dstStart+ed)-    !(Size (I# nBytes)) = sizeOfE sz n+    !(CountOf (I# nBytes)) = sizeOfE sz n unsafeCopyAtRO dst od src os n = loop od os   where     !endIndex = os `offsetPlusE` n@@ -272,12 +285,12 @@ --   the source array. unsafeCopyFrom :: (PrimType a, PrimType b)                => UArray a -- ^ Source array-               -> Size b -- ^ Length of the destination array+               -> CountOf b -- ^ Length of the destination array                -> (UArray a -> Offset a -> MUArray b s -> ST s ())                -- ^ Function called for each element in the source array                -> ST s (UArray b) -- ^ Returns the filled new array unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze-  where len = lengthSize v'+  where len = length v'         fill i r'             | i .==# len = return r'             | otherwise  = do f v' i r'@@ -293,7 +306,7 @@ unsafeFreeze (MUVecAddr start len fptr) = return $ UVecAddr start len fptr {-# INLINE unsafeFreeze #-} -unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Size ty -> prim (UArray ty)+unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) unsafeFreezeShrink (MUVecMA start _ pinnedState mba) n = unsafeFreeze (MUVecMA start n pinnedState mba) unsafeFreezeShrink (MUVecAddr start _ fptr) n = unsafeFreeze (MUVecAddr start n fptr) {-# INLINE unsafeFreezeShrink #-}@@ -303,9 +316,9 @@     ma' <- new len     copyAt ma' (Offset 0) ma (Offset 0) len     unsafeFreeze ma'-  where len = Size $ mutableLength ma+  where len = CountOf $ mutableLength ma -freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Size ty -> prim (UArray ty)+freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) freezeShrink ma n = do     ma' <- new n     copyAt ma' (Offset 0) ma (Offset 0) n@@ -316,9 +329,9 @@   where     doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()     doSlide (MUVecMA mbStart _ _ mba) start end  =-        primMutableByteArraySlideToStart mba (primOffsetOfE $ mbStart+start) (primOffsetOfE end)+        primMutableByteArraySlideToStart mba (offsetInBytes $ mbStart+start) (offsetInBytes end)     doSlide (MUVecAddr mbStart _ fptr) start end = withFinalPtr fptr $ \(Ptr addr) ->-        primMutableAddrSlideToStart addr (primOffsetOfE $ mbStart+start) (primOffsetOfE end)+        primMutableAddrSlideToStart addr (offsetInBytes $ mbStart+start) (offsetInBytes end)  -- | Thaw an immutable array. --@@ -331,7 +344,7 @@ -- | Create a new array of size @n by settings each cells through the -- function @f. create :: forall ty . PrimType ty-       => Size ty           -- ^ the size of the array+       => CountOf ty           -- ^ the size of the array        -> (Offset ty -> ty) -- ^ the function that set the value at the index        -> UArray ty         -- ^ the array created create n initializer@@ -349,8 +362,8 @@  -- | Create a pinned array that is filled by a 'filler' function (typically an IO call like hGetBuf) createFromIO :: PrimType ty-             => Size ty                  -- ^ the size of the array-             -> (Ptr ty -> IO (Size ty)) -- ^ filling function that+             => CountOf ty                  -- ^ the size of the array+             -> (Ptr ty -> IO (CountOf ty)) -- ^ filling function that              -> IO (UArray ty) createFromIO size filler     | size == 0 = return empty@@ -362,6 +375,16 @@             _ | r < 0     -> error "filler returned negative number"               | otherwise -> unsafeFreezeShrink mba r +-- | Freeze a chunk of memory pointed, of specific size into a new unboxed array+createFromPtr :: PrimType ty+              => Ptr ty+              -> CountOf ty+              -> IO (UArray ty)+createFromPtr p s = do+    ma <- new s+    copyFromPtr p s ma+    unsafeFreeze ma+ ----------------------------------------------------------------------- -- higher level collection implementation -----------------------------------------------------------------------@@ -379,14 +402,14 @@ singleton :: PrimType ty => ty -> UArray ty singleton ty = create 1 (const ty) -replicate :: PrimType ty => Word -> ty -> UArray ty-replicate sz ty = create (Size (integralCast sz)) (const ty)+replicate :: PrimType ty => CountOf ty -> ty -> UArray ty+replicate sz ty = create sz (const ty)  -- | make an array from a list of elements. vFromList :: PrimType ty => [ty] -> UArray ty vFromList l = runST $ do-    ma <- new (Size len)-    iter 0 l $ \i x -> unsafeWrite ma i x+    ma <- new (CountOf len)+    iter azero l $ \i x -> unsafeWrite ma i x     unsafeFreeze ma   where len = Data.List.length l         iter _  []     _ = return ()@@ -398,7 +421,7 @@     | len == 0  = []     | otherwise = unsafeDewrap goBa goPtr a   where-    !len = lengthSize a+    !len = length a     goBa ba start = loop start       where         !end = start `offsetPlusE` len@@ -414,32 +437,120 @@ equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool equal a b     | la /= lb  = False-    | otherwise = loop 0+    | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b   where-    !la = lengthSize a-    !lb = lengthSize b-    loop n | n .==# la = True-           | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1)+    !la = length a+    !lb = length b+    goBaBa ba1 start1 ba2 start2 = loop start1 start2+      where+        !end = start1 `offsetPlusE` la+        loop !i !o | i == end  = True+                   | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)+    goPtrPtr (Ptr addr1) start1 (Ptr addr2) start2 = pureST (loop start1 start2)+      where+        !end = start1 `offsetPlusE` la+        loop !i !o | i == end  = True+                   | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)+    goBaPtr ba1 start1 (Ptr addr2) start2 = pureST (loop start1 start2)+      where+        !end = start1 `offsetPlusE` la+        loop !i !o | i == end  = True+                   | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)+    goPtrBa (Ptr addr1) start1 ba2 start2 = pureST (loop start1 start2)+      where+        !end = start1 `offsetPlusE` la+        loop !i !o | i == end  = True+                   | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1) -{--sizeEqual :: PrimType ty => UArray ty -> UArray ty -> Bool-sizeEqual a b = length a == length b -- TODO optimise with direct comparaison of bytes or elements when possible--}+    o1 = Offset (I# 1#)+{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-}+{-# INLINEABLE [2] equal #-} +equalBytes :: UArray Word8 -> UArray Word8 -> Bool+equalBytes a b+    | la /= lb  = False+    | otherwise = memcmp a b (csizeOfSize $ sizeInBytes la) == 0+  where+    !la = length a+    !lb = length b++equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool+equalMemcmp a b+    | la /= lb  = False+    | otherwise = memcmp a b (csizeOfSize $ sizeInBytes la) == 0+  where+    !la = length a+    !lb = length b+ -- | Compare 2 vectors vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering-vCompare a b = loop 0+vCompare a b = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b   where-    !la = lengthSize a-    !lb = lengthSize b-    loop n-        | n .==# la = if la == lb then EQ else LT-        | n .==# lb = GT-        | otherwise =-            case unsafeIndex a n `compare` unsafeIndex b n of-                EQ -> loop (n+1)-                r  -> r+    !la = length a+    !lb = length b+    o1 = Offset (I# 1#)+    goBaBa ba1 start1 ba2 start2 = loop start1 start2+      where+        !end = start1 `offsetPlusE` min la lb+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primBaIndex ba1 i+                v2 = primBaIndex ba2 o+    goPtrPtr (Ptr addr1) start1 (Ptr addr2) start2 = pureST (loop start1 start2)+      where+        !end = start1 `offsetPlusE` min la lb+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primAddrIndex addr1 i+                v2 = primAddrIndex addr2 o+    goBaPtr ba1 start1 (Ptr addr2) start2 = pureST (loop start1 start2)+      where+        !end  = start1 `offsetPlusE` min la lb+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primBaIndex ba1 i+                v2 = primAddrIndex addr2 o+    goPtrBa (Ptr addr1) start1 ba2 start2 = pureST (loop start1 start2)+      where+        !end  = start1 `offsetPlusE` min la lb+        loop !i !o | i == end   = la `compare` lb+                   | v1 == v2   = loop (i + o1) (o + o1)+                   | otherwise  = v1 `compare` v2+          where v1 = primAddrIndex addr1 i+                v2 = primBaIndex ba2 o+-- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-}+{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-}+{-# INLINEABLE [2] vCompare #-} +vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering+vCompareBytes = vCompareMemcmp++vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering+vCompareMemcmp a b = cintToOrdering $ memcmp a b sz+  where+    la = length a+    lb = length b+    sz = csizeOfSize $ sizeInBytes $ min la lb+    cintToOrdering :: CInt -> Ordering+    cintToOrdering 0 = la `compare` lb+    cintToOrdering r | r < 0     = LT+                     | otherwise = GT+{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-}++memcmp :: PrimType ty => UArray ty -> UArray ty -> CSize -> CInt+memcmp a b sz = unsafeDewrap2+    (\s1 o1 s2 o2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)+    (\s1 o1 s2 o2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)+    (\s1 o1 s2 o2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)+    (\s1 o1 s2 o2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)+    a b+  where+    offsetToCSize ofs = csizeOfOffset $ offsetInBytes ofs+{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CSize -> CInt #-}+ -- | Append 2 arrays together by creating a new bigger array append :: PrimType ty => UArray ty -> UArray ty -> UArray ty append a b@@ -453,13 +564,13 @@         copyAt r (sizeAsOffset la) mb (Offset 0) lb         unsafeFreeze r   where-    !la = lengthSize a-    !lb = lengthSize b+    !la = length a+    !lb = length b  concat :: PrimType ty => [UArray ty] -> UArray ty concat [] = empty concat l  =-    case filterAndSum (Size 0) [] l of+    case filterAndSum (CountOf 0) [] l of         (_,[])            -> empty         (_,[x])           -> x         (totalLen,chunks) -> runST $ do@@ -470,15 +581,15 @@     -- TODO would go faster not to reverse but pack from the end instead     filterAndSum !totalLen acc []     = (totalLen, Prelude.reverse acc)     filterAndSum !totalLen acc (x:xs)-        | len == Size 0 = filterAndSum totalLen acc xs+        | len == CountOf 0 = filterAndSum totalLen acc xs         | otherwise      = filterAndSum (len+totalLen) (x:acc) xs-      where len = lengthSize x+      where len = length x      doCopy _ _ []     = return ()     doCopy r i (x:xs) = do         unsafeCopyAtRO r i x (Offset 0) lx         doCopy r (i `offsetPlusE` lx) xs-      where lx = lengthSize x+      where lx = length x  -- | update an array by creating a new array with the updates. --@@ -513,13 +624,13 @@ copyToPtr (UVecBA start sz _ ba) (Ptr p) = primitive $ \s1 ->     (# compatCopyByteArrayToAddr# ba offset p szBytes s1, () #)   where-    !(Offset (I# offset)) = primOffsetOfE start-    !(Size (I# szBytes)) = sizeInBytes sz+    !(Offset (I# offset)) = offsetInBytes start+    !(CountOf (I# szBytes)) = sizeInBytes sz copyToPtr (UVecAddr start sz fptr) dst =     unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes   where-    !(Offset os)    = primOffsetOfE start-    !(Size szBytes) = sizeInBytes sz+    !(Offset os)    = offsetInBytes start+    !(CountOf szBytes) = sizeInBytes sz  data TmpBA = TmpBA ByteArray# @@ -549,67 +660,80 @@     !(Offset os) = offsetOfE sz start {-# INLINE withPtr #-} -recast :: (PrimType a, PrimType b) => UArray a -> UArray b-recast = recast_ Proxy Proxy+-- | Recast an array of type a to an array of b+--+-- a and b need to have the same size otherwise this+-- raise an async exception+recast :: forall a b . (PrimType a, PrimType b) => UArray a -> UArray b+recast array+    | aTypeSize == bTypeSize = unsafeRecast array+    | missing   == 0         = unsafeRecast array+    | otherwise = throw $ InvalidRecast+                      (RecastSourceSize      alen)+                      (RecastDestinationSize $ alen + missing)   where-    recast_ :: (PrimType a, PrimType b)-            => Proxy a -> Proxy b -> UArray a -> UArray b-    recast_ pa pb array-        | aTypeSize == bTypeSize = unsafeRecast array-        | missing   == 0         = unsafeRecast array-        | otherwise = throw $ InvalidRecast-                          (RecastSourceSize      alen)-                          (RecastDestinationSize $ alen + missing)-      where-        aTypeSize@(Size as) = primSizeInBytes pa-        bTypeSize@(Size bs) = primSizeInBytes pb-        alen = length array * as-        missing = alen `mod` bs+    aTypeSize = primSizeInBytes (Proxy :: Proxy a)+    bTypeSize@(CountOf bs) = primSizeInBytes (Proxy :: Proxy b)+    (CountOf alen) = sizeInBytes (length array)+    missing = alen `mod` bs  unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b unsafeRecast (UVecBA start len pinStatus b) = UVecBA (primOffsetRecast start) (sizeRecast len) pinStatus b unsafeRecast (UVecAddr start len a) = UVecAddr (primOffsetRecast start) (sizeRecast len) (castFinalPtr a)+{-# INLINE [1] unsafeRecast #-}+{-# RULES "unsafeRecast from Word8" [2] forall a . unsafeRecast a = unsafeRecastBytes a #-} +unsafeRecastBytes :: PrimType a => UArray Word8 -> UArray a+unsafeRecastBytes (UVecBA start len pinStatus b) = UVecBA (primOffsetRecast start) (sizeRecast len) pinStatus b+unsafeRecastBytes (UVecAddr start len a) = UVecAddr (primOffsetRecast start) (sizeRecast len) (castFinalPtr a)+{-# INLINE [1] unsafeRecastBytes #-}+ null :: UArray ty -> Bool-null (UVecBA _ sz _ _) = sz == Size 0-null (UVecAddr _ l _)  = l == Size 0+null (UVecBA _ sz _ _) = sz == CountOf 0+null (UVecAddr _ l _)  = l == CountOf 0 -take :: PrimType ty => Int -> UArray ty -> UArray ty-take nbElems v-    | nbElems <= 0 = empty-    | n >= vlen    = v-    | otherwise    =+-- | Take a count of elements from the array and create an array with just those elements+take :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+take n v+    | n <= 0    = empty+    | n >= vlen = v+    | otherwise =         case v of             UVecBA start _ pinst ba -> UVecBA start n pinst ba             UVecAddr start _ fptr   -> UVecAddr start n fptr   where-    n    = Size nbElems-    vlen = lengthSize v+    vlen = length v -drop :: PrimType ty => Int -> UArray ty -> UArray ty-drop nbElems v-    | nbElems <= 0 = v-    | n >= vlen    = empty-    | otherwise    =+unsafeTake :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+unsafeTake sz (UVecBA start _ pinst ba) = UVecBA start sz pinst ba+unsafeTake sz (UVecAddr start _ fptr)   = UVecAddr start sz fptr++-- | Drop a count of elements from the array and return the new array minus those dropped elements+drop :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+drop n v+    | n <= 0    = v+    | n >= vlen = empty+    | otherwise =         case v of             UVecBA start len pinst ba -> UVecBA (start `offsetPlusE` n) (len - n) pinst ba             UVecAddr start len fptr   -> UVecAddr (start `offsetPlusE` n) (len - n) fptr   where-    n    = Size nbElems-    vlen = lengthSize v+    vlen = length v -splitAt :: PrimType ty => Int -> UArray ty -> (UArray ty, UArray ty)+-- | Split an array into two, with a count of at most N elements in the first one+-- and the remaining in the other.+splitAt :: PrimType ty => CountOf ty -> UArray ty -> (UArray ty, UArray ty) splitAt nbElems v-    | nbElems <= 0   = (empty, v)-    | n == Size vlen = (v, empty)-    | otherwise      =+    | nbElems <= 0 = (empty, v)+    | n == vlen    = (v, empty)+    | otherwise    =         case v of             UVecBA start len pinst ba -> ( UVecBA start                   n         pinst ba                                          , UVecBA (start `offsetPlusE` n) (len - n) pinst ba)             UVecAddr start len fptr    -> ( UVecAddr start                   n         fptr                                           , UVecAddr (start `offsetPlusE` n) (len - n) fptr)   where-    n    = Size $ min nbElems vlen+    n    = min nbElems vlen     vlen = length v  splitElem :: PrimType ty => ty -> UArray ty -> (# UArray ty, UArray ty #)@@ -642,23 +766,33 @@ {-# SPECIALIZE [3] splitElem :: Word8 -> UArray Word8 -> (# UArray Word8, UArray Word8 #) #-} {-# SPECIALIZE [3] splitElem :: Word32 -> UArray Word32 -> (# UArray Word32, UArray Word32 #) #-} -revTake :: PrimType ty => Int -> UArray ty -> UArray ty-revTake nbElems v = drop (length v - nbElems) v+-- inverse a CountOf that is specified from the end (e.g. take n elements from the end)+countFromStart :: UArray ty -> CountOf ty -> CountOf ty+countFromStart v sz@(CountOf sz')+    | sz >= len = CountOf 0+    | otherwise = CountOf (len' - sz')+  where len@(CountOf len') = length v -revDrop :: PrimType ty => Int -> UArray ty -> UArray ty-revDrop nbElems v = take (length v - nbElems) v+-- | Take the N elements from the end of the array+revTake :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+revTake n v = drop (countFromStart v n) v -revSplitAt :: PrimType ty => Int -> UArray ty -> (UArray ty, UArray ty)-revSplitAt n v = (drop idx v, take idx v)-  where idx = length v - n+-- | Drop the N elements from the end of the array+revDrop :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+revDrop n v = take (countFromStart v n) v +-- | Split an array at the N element from the end, and return+-- the last N elements in the first part of the tuple, and whatever first+-- elements remaining in the second+revSplitAt :: PrimType ty => CountOf ty -> UArray ty -> (UArray ty, UArray ty)+revSplitAt n v = (drop sz v, take sz v) where sz = countFromStart v n+ splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty] splitOn xpredicate ivec     | len == 0  = [mempty]     | otherwise = runST $ unsafeIndexer ivec (pureST . go ivec xpredicate)   where-    !len = lengthSize ivec-    --go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s [UArray ty]+    !len = length ivec     go v predicate getIdx = loop 0 0       where         loop !prevIdx !idx@@ -684,23 +818,23 @@   where     newLen = endIdx - startIdx     endIdx = min expectedEndIdx (0 `offsetPlusE` len)-    len = lengthSize vec+    len = length vec -findIndex :: PrimType ty => ty -> UArray ty -> Maybe Int+findIndex :: forall ty . PrimType ty => ty -> UArray ty -> Maybe (Offset ty) findIndex tyOuter ba = runST $ unsafeIndexer ba (go tyOuter)   where     !len = length ba -    go :: PrimType ty => ty -> (Offset ty -> ty) -> ST s (Maybe Int)+    go :: PrimType ty => ty -> (Offset ty -> ty) -> ST s (Maybe (Offset ty))     go ty getIdx = loop (Offset 0)       where-        loop ofs@(Offset i)-            | ofs == Offset len = return Nothing-            | getIdx ofs == ty  = return $ Just i-            | otherwise         = loop (ofs + Offset 1)-{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe Int #-}+        loop ofs+            | ofs .==# len     = return Nothing+            | getIdx ofs == ty = return $ Just ofs+            | otherwise        = loop (ofs + Offset 1)+{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} -break :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty)+break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) break xpredicate xv     | len == 0  = (empty, empty)     | otherwise = runST $ unsafeIndexer xv (go xv xpredicate)@@ -709,9 +843,9 @@     go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s (UArray ty, UArray ty)     go v predicate getIdx = return (findBreak $ Offset 0)       where-        findBreak !i@(Offset io)-            | i == Offset len     = (v, empty)-            | predicate (getIdx i) = splitAt io v+        findBreak !i+            | i .==# len           = (v, empty)+            | predicate (getIdx i) = splitAt (offsetAsSize i) v             | otherwise            = findBreak (i + Offset 1)         {-# INLINE findBreak #-}     {-# INLINE go #-}@@ -756,7 +890,7 @@     | len <= 1  = v     | otherwise = runST $ unsafeCopyFrom v newSize (go sep)   where-    len = lengthSize v+    len = length v     newSize = (scale (2:: Word) len) - 1      go :: PrimType ty => ty -> UArray ty -> Offset ty -> MUArray ty s -> ST s ()@@ -774,39 +908,39 @@  map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))-  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (lengthSize a)+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)  mapIndex :: (PrimType a, PrimType b) => (Offset b -> a -> b) -> UArray a -> UArray b-mapIndex f a = create (sizeCast Proxy $ lengthSize a) (\i -> f i $ unsafeIndex a (offsetCast Proxy i))+mapIndex f a = create (sizeCast Proxy $ length a) (\i -> f i $ unsafeIndex a (offsetCast Proxy i))  cons :: PrimType ty => ty -> UArray ty -> UArray ty cons e vec-    | len == Size 0 = singleton e+    | len == CountOf 0 = singleton e     | otherwise     = runST $ do         muv <- new (len + 1)         unsafeCopyAtRO muv 1 vec 0 len         unsafeWrite muv 0 e         unsafeFreeze muv   where-    !len = lengthSize vec+    !len = length vec  snoc :: PrimType ty => UArray ty -> ty -> UArray ty snoc vec e-    | len == Size 0 = singleton e+    | len == CountOf 0 = singleton e     | otherwise     = runST $ do-        muv <- new (len + Size 1)+        muv <- new (len + CountOf 1)         unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len-        unsafeWrite muv (0 `offsetPlusE` lengthSize vec) e+        unsafeWrite muv (0 `offsetPlusE` length vec) e         unsafeFreeze muv   where-     !len = lengthSize vec+     !len = length vec  uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty) uncons vec     | nbElems == 0 = Nothing     | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))   where-    !nbElems = lengthSize vec+    !nbElems = length vec  unsnoc :: PrimType ty => UArray ty -> Maybe (UArray ty, ty) unsnoc vec@@ -814,12 +948,12 @@     | otherwise    = Just (sub vec 0 lastElem, unsafeIndex vec lastElem)   where     !lastElem = 0 `offsetPlusE` (nbElems - 1)-    !nbElems = lengthSize vec+    !nbElems = length vec  find :: PrimType ty => (ty -> Bool) -> UArray ty -> Maybe ty find predicate vec = loop 0   where-    !len = lengthSize vec+    !len = length vec     loop i         | i .==# len = Nothing         | otherwise  =@@ -831,7 +965,7 @@     | len == 0  = empty     | otherwise = runST (thaw vec >>= doSort xford)   where-    len = lengthSize vec+    len = length vec     doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MUArray ty (PrimState prim) -> prim (UArray ty)     doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma       where@@ -868,7 +1002,7 @@  reverse :: PrimType ty => UArray ty -> UArray ty reverse a-    | len == Size 0 = empty+    | len == CountOf 0 = empty     | otherwise     = runST $ do         ma <- newNative len $ \mba ->                 case a of@@ -876,7 +1010,7 @@                     (UVecAddr start _ fptr) -> withFinalPtr fptr $ \ptr -> goAddr endOfs mba ptr start         unsafeFreeze ma   where-    !len = lengthSize a+    !len = length a     !endOfs = Offset 0 `offsetPlusE` len      goNative :: PrimType ty => Offset ty -> MutableByteArray# s -> ByteArray# -> Offset ty -> ST s ()@@ -897,7 +1031,7 @@ foldl :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a foldl f initialAcc vec = loop 0 initialAcc   where-    len = lengthSize vec+    len = length vec     loop i acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -905,7 +1039,7 @@ foldr :: PrimType ty => (ty -> a -> a) -> a -> UArray ty -> a foldr f initialAcc vec = loop 0   where-    !len = lengthSize vec+    !len = length vec     loop i         | i .==# len = initialAcc         | otherwise  = unsafeIndex vec i `f` loop (i+1)@@ -913,7 +1047,7 @@ foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    !len = lengthSize vec+    !len = length vec     loop i !acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -938,30 +1072,30 @@     | sizeChunksI <= 0 = builderBuild 64 ab     | otherwise        = do         first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks)         cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)         -- Build final array         let totalSize = prevChunksSize st + offsetAsSize i         new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze   where-      sizeChunks = Size sizeChunksI+      sizeChunks = CountOf sizeChunksI        fillFromEnd _   []     mua = return mua       fillFromEnd !end (x:xs) mua = do-          let sz = lengthSize x+          let sz = length x           unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz           fillFromEnd (end - sz) xs mua  toHexadecimal :: PrimType ty => UArray ty -> UArray Word8 toHexadecimal ba-    | len == Size 0 = empty+    | len == CountOf 0 = empty     | otherwise     = runST $ do         ma <- new (len `scale` 2)         unsafeIndexer b8 (go ma)         unsafeFreeze ma   where     b8 = unsafeRecast ba-    !len = lengthSize b8+    !len = length b8     !endOfs = Offset 0 `offsetPlusE` len      go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s ()

@@ -22,7 +22,7 @@     len = mutableLengthSize mba  {--mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Offset Word8 -> Size Word8 -> prim ()+mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Offset Word8 -> CountOf Word8 -> prim () mutableByteArraySetBetween mba val offset size     | offset < 0                        = primOutOfBound OOB_MemSet offset                      len     | offset > len || offset+size > len = primOutOfBound OOB_MemSet (offset `OffsetPlusE` size) len

@@ -26,6 +26,8 @@     , newNative     , mutableForeignMem     , copyAt+    , copyFromPtr+    , copyToPtr     , sub     -- , copyAddr     -- * Reading and Writing cells@@ -49,18 +51,18 @@ import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.Exception import           Foundation.Numerical--- import           Foreign.Marshal.Utils (copyBytes)+import           Foreign.Marshal.Utils (copyBytes)  -- | A Mutable array of types built on top of GHC primitive. -- -- Element in this array can be modified in place. data MUArray ty st =       MUVecMA {-# UNPACK #-} !(Offset ty)-              {-# UNPACK #-} !(Size ty)+              {-# UNPACK #-} !(CountOf ty)               {-# UNPACK #-} !PinnedStatus                              (MutableByteArray# st)     | MUVecAddr {-# UNPACK #-} !(Offset ty)-                {-# UNPACK #-} !(Size ty)+                {-# UNPACK #-} !(CountOf ty)                                !(FinalPtr ty)  mutableArrayProxyTy :: MUArray ty st -> Proxy ty@@ -117,24 +119,24 @@ -- all the cells are uninitialized and could contains invalid values. -- -- All mutable arrays are allocated on a 64 bits aligned addresses-newPinned :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim))+newPinned :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) newPinned n = newFake n Proxy-  where newFake :: (PrimMonad prim, PrimType ty) => Size ty -> Proxy ty -> prim (MUArray ty (PrimState prim))+  where newFake :: (PrimMonad prim, PrimType ty) => CountOf ty -> Proxy ty -> prim (MUArray ty (PrimState prim))         newFake sz ty = primitive $ \s1 ->             case newAlignedPinnedByteArray# bytes 8# s1 of                 (# s2, mba #) -> (# s2, MUVecMA (Offset 0) sz pinned mba #)           where-                !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz+                !(CountOf (I# bytes)) = sizeOfE (primSizeInBytes ty) sz         {-# INLINE newFake #-} -newUnpinned :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim))+newUnpinned :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) newUnpinned n = newFake n Proxy-  where newFake :: (PrimMonad prim, PrimType ty) => Size ty -> Proxy ty -> prim (MUArray ty (PrimState prim))+  where newFake :: (PrimMonad prim, PrimType ty) => CountOf ty -> Proxy ty -> prim (MUArray ty (PrimState prim))         newFake sz ty = primitive $ \s1 ->             case newByteArray# bytes s1 of                 (# s2, mba #) -> (# s2, MUVecMA (Offset 0) sz unpinned mba #)           where-                !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz+                !(CountOf (I# bytes)) = sizeOfE (primSizeInBytes ty) sz         {-# INLINE newFake #-}  empty :: PrimMonad prim => prim (MUArray ty (PrimState prim))@@ -148,7 +150,7 @@ -- -- You can change the threshold value used by setting the environment variable -- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@.-new :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim))+new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim)) new sz     | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz     | otherwise                        = newPinned sz@@ -165,7 +167,7 @@ mutableSame (MUVecAddr {})   (MUVecMA {})     = False  -newNative :: (PrimMonad prim, PrimType ty) => Size ty -> (MutableByteArray# (PrimState prim) -> prim ()) -> prim (MUArray ty (PrimState prim))+newNative :: (PrimMonad prim, PrimType ty) => CountOf ty -> (MutableByteArray# (PrimState prim) -> prim ()) -> prim (MUArray ty (PrimState prim)) newNative n f = do     muvec <- new n     case muvec of@@ -176,7 +178,7 @@                   => FinalPtr ty -- ^ the start pointer with a finalizer                   -> Int         -- ^ the number of elements (in elements, not bytes)                   -> prim (MUArray ty (PrimState prim))-mutableForeignMem fptr nb = return $ MUVecAddr (Offset 0) (Size nb) fptr+mutableForeignMem fptr nb = return $ MUVecAddr (Offset 0) (CountOf nb) fptr  -- | Copy a number of elements from an array to another array with offsets copyAt :: (PrimMonad prim, PrimType ty)@@ -184,7 +186,7 @@        -> Offset ty                  -- ^ offset at destination        -> MUArray ty (PrimState prim) -- ^ source array        -> Offset ty                  -- ^ offset at source-       -> Size ty                    -- ^ number of elements to copy+       -> CountOf ty                    -- ^ number of elements to copy        -> prim () copyAt (MUVecMA dstStart _ _ dstMba) ed uvec@(MUVecMA srcStart _ _ srcBa) es n =     primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #)@@ -192,7 +194,7 @@     !sz                 = primSizeInBytes (mutableArrayProxyTy uvec)     !(Offset (I# os))   = offsetOfE sz (srcStart + es)     !(Offset (I# od))   = offsetOfE sz (dstStart + ed)-    !(Size (I# nBytes)) = sizeOfE sz n+    !(CountOf (I# nBytes)) = sizeOfE sz n copyAt (MUVecMA dstStart _ _ dstMba) ed muvec@(MUVecAddr srcStart _ srcFptr) es n =     withFinalPtr srcFptr $ \srcPtr ->         let !(Ptr srcAddr) = srcPtr `plusPtr` os@@ -201,7 +203,7 @@     !sz                 = primSizeInBytes (mutableArrayProxyTy muvec)     !(Offset os)        = offsetOfE sz (srcStart + es)     !(Offset (I# od))   = offsetOfE sz (dstStart + ed)-    !(Size (I# nBytes)) = sizeOfE sz n+    !(CountOf (I# nBytes)) = sizeOfE sz n copyAt dst od src os n = loop od os   where     !endIndex = os `offsetPlusE` n@@ -217,16 +219,16 @@ sub (MUVecMA start sz pstatus mba) dropElems' takeElems     | takeElems <= 0 = empty     | resultEmpty    = empty-    | otherwise      = return $ MUVecMA (start `offsetPlusE` dropElems) (min (Size takeElems) (sz - dropElems)) pstatus mba+    | otherwise      = return $ MUVecMA (start `offsetPlusE` dropElems) (min (CountOf takeElems) (sz - dropElems)) pstatus mba   where-    dropElems = max 0 (Size dropElems')+    dropElems = max 0 (CountOf dropElems')     resultEmpty = dropElems >= sz sub (MUVecAddr start sz addr) dropElems' takeElems     | takeElems <= 0 = empty     | resultEmpty    = empty-    | otherwise      = return $ MUVecAddr (start `offsetPlusE` dropElems) (min (Size takeElems) (sz - dropElems)) addr+    | otherwise      = return $ MUVecAddr (start `offsetPlusE` dropElems) (min (CountOf takeElems) (sz - dropElems)) addr   where-    dropElems = max 0 (Size dropElems')+    dropElems = max 0 (CountOf dropElems')     resultEmpty = dropElems >= sz  {-@@ -235,7 +237,7 @@          -> Offset ty                  -- ^ offset at destination          -> Ptr Word8                   -- ^ source ptr          -> Offset ty                  -- ^ offset at source-         -> Size ty                    -- ^ number of elements to copy+         -> CountOf ty                    -- ^ number of elements to copy          -> prim () copyAddr (MUVecMA dstStart _ _ dst) dstOfs (Ptr src) srcOfs sz = primitive $ \s ->     (# compatCopyAddrToByteArray# (plusAddr# src os) dst od sz s, () #)@@ -247,10 +249,10 @@  -- | return the numbers of elements in a mutable array mutableLength :: PrimType ty => MUArray ty st -> Int-mutableLength (MUVecMA _ (Size end) _ _) = end-mutableLength (MUVecAddr _ (Size end) _) = end+mutableLength (MUVecMA _ (CountOf end) _ _) = end+mutableLength (MUVecAddr _ (CountOf end) _) = end -mutableLengthSize :: PrimType ty => MUArray ty st -> Size ty+mutableLengthSize :: PrimType ty => MUArray ty st -> CountOf ty mutableLengthSize (MUVecMA _ end _ _) = end mutableLengthSize (MUVecAddr _ end _) = end @@ -299,3 +301,39 @@                -> (Ptr ty -> prim a)                -> prim a withMutablePtr = withMutablePtrHint False False++-- | Copy from a pointer, @count@ elements, into the mutable array+copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty)+            => Ptr ty -> CountOf ty -> MUArray ty (PrimState prim) -> prim ()+copyFromPtr (Ptr p) count (MUVecMA ofs arrSz _ mba)+    | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz+    | otherwise     = primitive $ \st -> (# copyAddrToByteArray# p mba od countBytes st, () #)+  where+    !sz                     = primSizeInBytes (Proxy :: Proxy ty)+    !(CountOf (I# countBytes)) = sizeOfE sz count+    !(Offset (I# od))       = offsetOfE sz ofs+copyFromPtr p count (MUVecAddr ofs arrSz fptr)+    | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz+    | otherwise     = withFinalPtr fptr $ \dstPtr ->+        unsafePrimFromIO $ copyBytes (dstPtr `plusPtr` os) p bytes+  where+        sz = primSizeInBytes (Proxy :: Proxy ty)+        !(CountOf bytes) = sizeOfE sz count+        !(Offset os) = offsetOfE sz ofs++-- | Copy all the block content to the memory starting at the destination address+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)+          => MUArray ty (PrimState prim) -- ^ the source mutable array to copy+          -> Ptr ty                      -- ^ The destination address where the copy is going to start+          -> prim ()+copyToPtr (MUVecMA start sz _ ma) (Ptr p) = primitive $ \s1 ->+    case unsafeFreezeByteArray# ma s1 of+        (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba offset p szBytes s2, () #)+  where+    !(Offset (I# offset)) = offsetInBytes start+    !(CountOf (I# szBytes)) = sizeInBytes sz+copyToPtr (MUVecAddr start sz fptr) dst =+    unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes+  where+    !(Offset os)    = offsetInBytes start+    !(CountOf szBytes) = sizeInBytes sz

@@ -20,7 +20,7 @@ -- progress packing the elements inside. data BuildingState collection mutCollection step state = BuildingState     { prevChunks     :: [collection]-    , prevChunksSize :: !(Size step)+    , prevChunksSize :: !(CountOf step)     , curChunk       :: mutCollection state-    , chunkSize      :: !(Size step)+    , chunkSize      :: !(CountOf step)     }

@@ -1,3 +1,11 @@+-- |+-- Module      : Foundation.Check+-- License     : BSD-style+-- Maintainer  : Foundation maintainers+--+-- An implementation of a test framework+-- and property expression & testing+-- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}@@ -23,343 +31,60 @@     , propertyAnd     , propertyFail     , forAll-    -- * As Program-    , defaultMain+    -- * Check Plan+    , Check+    , validate+    , pick+    , iterateProperty     ) where -import qualified Prelude (fromIntegral, read)-import           Foundation.Internal.Base-import           Foundation.Class.Bifunctor (bimap)-import           Foundation.System.Info (os, OS(..))-import           Foundation.Collection-import           Foundation.Numerical-import           Foundation.String-import           Foundation.IO.Terminal+import           Foundation.Primitive.Imports+import           Foundation.Primitive.IntegralConv+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Check.Gen import           Foundation.Check.Arbitrary import           Foundation.Check.Property-import           Foundation.Random+import           Foundation.Check.Types+import           Foundation.Check.Print import           Foundation.Monad import           Foundation.Monad.State-import           Foundation.List.DList+import           Foundation.Numerical import           Control.Exception (evaluate, SomeException)-import           System.Exit-import           System.Environment (getArgs) --- different type of tests-data Test where-    -- Unit test-    Unit     :: String -> IO () -> Test-    -- Property test-    Property :: IsProperty prop => String -> prop -> Test-    -- Multiples tests grouped together-    Group    :: String -> [Test] -> Test---- | Name of a test-testName :: Test -> String-testName (Unit s _)     = s-testName (Property s _) = s-testName (Group s _)    = s--groupHasSubGroup :: [Test] -> Bool-groupHasSubGroup [] = False-groupHasSubGroup (Group{}:_) = True-groupHasSubGroup (_:xs) = groupHasSubGroup xs--data PropertyResult =-      PropertySuccess-    | PropertyFailed  String-    deriving (Show,Eq)--data TestResult =-      PropertyResult String Word64      PropertyResult-    | GroupResult    String HasFailures [TestResult]-    deriving (Show)--type HasFailures = Word64--nbFail :: TestResult -> HasFailures-nbFail (PropertyResult _ _ (PropertyFailed _)) = 1-nbFail (PropertyResult _ _ PropertySuccess)    = 0-nbFail (GroupResult    _ t _)                  = t--nbTests :: TestResult -> Word64-nbTests (PropertyResult _ t _) = t-nbTests (GroupResult _ _ l) = foldl' (+) 0 $ fmap nbTests l--parseArgs :: [[Char]] -> Config -> Config-parseArgs [] cfg = cfg-parseArgs ("--seed":[])     _  = error "option `--seed' is missing a parameter"-parseArgs ("--seed":x:xs)  cfg = parseArgs xs $ cfg { getSeed = Prelude.read x }-parseArgs ("--tests":[])   _   = error "option `--tests' is missing a parameter"-parseArgs ("--tests":x:xs) cfg = parseArgs xs $ cfg { numTests = Prelude.read x }-parseArgs ("--quiet":xs)   cfg = parseArgs xs $ cfg { displayOptions = DisplayTerminalErrorOnly }-parseArgs ("--verbose":xs) cfg = parseArgs xs $ cfg { displayOptions = DisplayTerminalVerbose }-parseArgs ("--help":_)     _   = error $ mconcat-    [ "--seed <seed>: the seed to use to generate arbitrary value.\n"-    , "--tests <tests>: the number of tests to perform for every property tests.\n"-    , "--quiet: print only the errors to the standard output\n"-    , "--verbose: print every property tests to the stand output.\n"-    ]-parseArgs (x:_) _ = error $ "unknown parameter: " <> show x---- | Run tests-defaultMain :: Test -> IO ()-defaultMain t = do-    -- generate a new seed-    seed <- getRandomPrimType-    -- parse arguments-    cfg <- flip parseArgs (defaultConfig seed) <$> getArgs--    putStrLn $ "\nSeed: " <> fromList (show $ getSeed cfg) <> "\n"--    (_, cfg') <- runStateT (runCheck $ test t) cfg-    let oks = testPassed cfg'-        kos = testFailed cfg'-        tot = oks + kos-    if kos > 0-        then do-          putStrLn $ "Failed " <> fromList (show kos) <> " out of " <> fromList (show tot)-          exitFailure-        else do-          putStrLn $ "Succeed " <> fromList (show oks) <> " test(s)"-          exitSuccess---- | internal check monad for facilitating the tests traversal-newtype Check a = Check { runCheck :: StateT Config IO a }-  deriving (Functor, Applicative, Monad, MonadIO)-instance MonadState Check where-    type State Check = Config-    withState = Check . withState--type Seed = Word64-data Config = Config-    { testPath     :: !(DList String)-        -- ^ for internal use when pretty printing-    , indent       :: !Word-        -- ^ for internal use when pretty printing-    , testPassed   :: !Word-    , testFailed   :: !Word-    , getSeed      :: !Seed-        -- ^ the seed for the tests-    , getGenParams :: !GenParams-        -- ^ Parameters for the generator-        ---        -- default:-        --   * 32bits long numbers;-        --   * array of 512 elements max;-        --   * string of 8192 bytes max.-        ---    , numTests     :: !Word64-        -- ^ the number of tests to perform on every property.-        ---        -- default: 100-    , displayOptions :: !DisplayOption-    }--data DisplayOption-    = DisplayTerminalErrorOnly-    | DisplayGroupOnly-    | DisplayTerminalVerbose-  deriving (Eq, Ord, Enum, Bounded, Show)--onDisplayOption :: DisplayOption -> Check () -> Check ()-onDisplayOption opt chk = do-    on <- (<=) opt . displayOptions <$> get-    if on then chk else return ()--whenErrorOnly :: Check () -> Check ()-whenErrorOnly = onDisplayOption DisplayTerminalErrorOnly--whenGroupOnly :: Check () -> Check ()-whenGroupOnly = onDisplayOption DisplayGroupOnly--whenVerbose :: Check () -> Check ()-whenVerbose = onDisplayOption DisplayTerminalVerbose--passed :: Check ()-passed = withState $ \s -> ((), s { testPassed = testPassed s + 1 })--failed :: Check ()-failed = withState $ \s -> ((), s { testFailed = testFailed s + 1 })---- | create the default configuration------ see @Config@ for details-defaultConfig :: Seed -> Config-defaultConfig s = Config-    { testPath     = mempty-    , indent       = 0-    , testPassed   = 0-    , testFailed   = 0-    , getSeed      = s-    , getGenParams = params-    , numTests     = 100-    , displayOptions = DisplayGroupOnly-    }-  where-    params = GenParams-        { genMaxSizeIntegral = 32   -- 256 bits maximum numbers-        , genMaxSizeArray    = 512  -- 512 elements-        , genMaxSizeString   = 8192 -- 8K string-        }--test :: Test -> Check TestResult-test (Group s l) = pushGroup s l-test (Unit _ _) = undefined-test (Property name prop) = do-    r'@(PropertyResult _ nb r) <- testProperty name (property prop)+validate :: IsProperty prop => String -> prop -> Check ()+validate propertyName prop = Check $ do+    (genrng, params) <- withState $ \st -> ( (planRng st, planParams st)+                                           , st { planValidations = planValidations st + 1 }+                                           )+    (r,nb) <- liftIO $ iterateProperty 100 params genrng (property prop)     case r of-        PropertySuccess  -> whenVerbose $ displayPropertySucceed name nb-        PropertyFailed w -> whenErrorOnly $ displayPropertyFailed name nb w-    return r'--displayCurrent :: String -> Check ()-displayCurrent name = do-    i <- indent <$> get-    liftIO $ putStrLn $ replicate i ' ' <> name--displayPropertySucceed :: String -> Word64 -> Check ()-displayPropertySucceed name nb = do-    i <- indent <$> get-    liftIO $ putStrLn $ mconcat-        [ replicate i ' '-        , successString, name-        , " ("-        , fromList $ show nb-        , if nb == 1 then " test)" else " tests)"-        ]--successString :: String-successString = case os of-    Right Linux -> " ✓ "-    Right OSX   -> " ✓ "-    _           -> "[SUCCESS]"-{-# NOINLINE successString #-}--failureString :: String-failureString = case os of-    Right Linux -> " ✗ "-    Right OSX   -> " ✗ "-    _           -> "[ ERROR ]"-{-# NOINLINE failureString #-}--displayPropertyFailed :: String -> Word64 -> String -> Check ()-displayPropertyFailed name nb w = do-    seed <- getSeed <$> get-    i <- indent <$> get-    liftIO $ do-        putStrLn $ mconcat-          [ replicate i ' '-          , failureString, name-          , " failed after "-          , fromList $ show nb-          , if nb == 1 then " test" else " tests:"-          ]-        putStrLn $ replicate i ' ' <> "   use param: --seed " <> fromList (show seed)-        putStrLn w--pushGroup :: String -> [Test] -> Check TestResult-pushGroup name list = do-    whenGroupOnly $ if groupHasSubGroup list then displayCurrent name else return ()-    withState $ \s -> ((), s { testPath = push (testPath s) name, indent = indent s + 2 })-    results <- mapM test list-    withState $ \s -> ((), s { testPath = pop (testPath s), indent = indent s - 2 })-    let totFail = foldl' (+) 0 $ fmap nbFail results-        tot = foldl'(+) 0 $ fmap nbTests results-    whenGroupOnly $ case (groupHasSubGroup list, totFail) of-        (True, _)              -> return ()-        (False, n) | n > 0     -> displayPropertyFailed name n ""-                   | otherwise -> displayPropertySucceed name tot-    return $ GroupResult name totFail results-  where-    push = snoc-    pop = maybe mempty fst . unsnoc--testProperty :: String -> Property -> Check TestResult-testProperty name prop = do-    seed <- getSeed <$> get-    path <- testPath <$> get-    let rngIt = genRng seed (name : toList path)+        PropertySuccess        -> return ()+        PropertyFailed failMsg -> do+            withState $ \st -> ((), st { planFailures = PropertyResult propertyName nb (PropertyFailed failMsg) : planFailures st })+            return () -    maxTests <- numTests <$> get+pick :: String -> IO a -> Check a+pick _ io = Check $ do+    -- TODO catch most exception to report failures+    r <- liftIO $ io+    pure r -    (res, nb) <- iterProp 1 maxTests rngIt-    return (PropertyResult name nb res)+iterateProperty :: CountOf TestResult ->  GenParams -> (Word64 -> GenRng) -> Property -> IO (PropertyResult, CountOf TestResult)+iterateProperty limit genParams genRngIter prop = iterProp 1   where-    iterProp !n !limit !rngIt-      | n == limit = passed >> return (PropertySuccess, n)+    iterProp !iter+      | iter == limit = return (PropertySuccess, iter)       | otherwise  = do-          params <- getGenParams <$> get-          r <- liftIO $ toResult n params+          r <- liftIO $ toResult           case r of-              (PropertyFailed e, _)               -> failed >> return (PropertyFailed e, n)-              (PropertySuccess, cont) | cont      -> iterProp (n+1) limit rngIt-                                      | otherwise -> passed >> return (PropertySuccess, n)+              (PropertyFailed e, _)               -> return (PropertyFailed e, iter)+              (PropertySuccess, cont) | cont      -> iterProp (iter+1)+                                      | otherwise -> return (PropertySuccess, iter)         where-          toResult :: Word64 -> GenParams -> IO (PropertyResult, Bool)-          toResult it params =-                    (propertyToResult <$> evaluate (runGen (unProp prop) (rngIt it) params))-            `catch` (\(e :: SomeException) -> return (PropertyFailed (fromList $ show e), False))--    propertyToResult p =-        let args   = getArgs p-            checks = getChecks p-         in if checkHasFailed checks-                then printError args checks-                else (PropertySuccess, length args > 0)--    printError args checks = (PropertyFailed (mconcat $ loop 1 args), False)-      where-        loop :: Word -> [String] -> [String]-        loop _ []      = printChecks checks-        loop !i (a:as) = "parameter " <> fromList (show i) <> " : " <> a <> "\n" : loop (i+1) as-    printChecks (PropertyBinaryOp True _ _ _)     = []-    printChecks (PropertyBinaryOp False n a b) =-        [ "Property `a " <> n <> " b' failed where:\n"-        , "    a = " <> a <> "\n"-        , "        " <> bl1 <> "\n"-        , "    b = " <> b <> "\n"-        , "        " <> bl2 <> "\n"-        ]-      where-        (bl1, bl2) = diffBlame a b-    printChecks (PropertyNamed True _)            = []-    printChecks (PropertyNamed False e)           = ["Property " <> e <> " failed"]-    printChecks (PropertyBoolean True)            = []-    printChecks (PropertyBoolean False)           = ["Property failed"]-    printChecks (PropertyFail _ e)                = ["Property failed: " <> e]-    printChecks (PropertyAnd True _ _)            = []-    printChecks (PropertyAnd False a1 a2) =-            [ "Property `cond1 && cond2' failed where:\n"-            , "   cond1 = " <> h1 <> "\n"--            ]-            <> ((<>) "           " <$>  hs1)-            <>-            [ "   cond2 = " <> h2 <> "\n"-            ]-            <> ((<>) "           " <$> hs2)-      where-        (h1, hs1) = f a1-        (h2, hs2) = f a2-        f a = case printChecks a of-                      [] -> ("Succeed", [])-                      (x:xs) -> (x, xs)--    getArgs (PropertyArg a p) = a : getArgs p-    getArgs (PropertyEOA _) = []--    getChecks (PropertyArg _ p) = getChecks p-    getChecks (PropertyEOA c  ) = c+          iterW64 :: Word64+          iterW64 = let (CountOf iter') = iter in integralCast (integralUpsize iter' :: Int64) -diffBlame :: String -> String -> (String, String)-diffBlame a b = bimap fromList fromList $ go ([], []) (toList a) (toList b)-  where-    go (acc1, acc2) [] [] = (acc1, acc2)-    go (acc1, acc2) l1 [] = (acc1 <> blaming (length l1), acc2)-    go (acc1, acc2) [] l2 = (acc1                       , acc2 <> blaming (length l2))-    go (acc1, acc2) (x:xs) (y:ys)-        | x == y    = go (acc1 <> " ", acc2 <> " ") xs ys-        | otherwise = go (acc1 <> "^", acc2 <> "^") xs ys-    blaming n = replicate (Prelude.fromIntegral n) '^'+          -- TODO revisit to let through timeout and other exception like ctrl-c or thread killing.+          toResult :: IO (PropertyResult, Bool)+          toResult = (propertyToResult <$> evaluate (runGen (unProp prop) (genRngIter iterW64) genParams))+            `catch` (\(e :: SomeException) -> return (PropertyFailed (show e), False))

@@ -13,6 +13,7 @@ import           Foundation.Primitive import           Foundation.Primitive.IntegralConv (wordToChar) import           Foundation.Primitive.Floating+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Check.Gen import           Foundation.Random import           Foundation.Bits@@ -52,6 +53,8 @@     arbitrary = arbitraryPrimtype instance Arbitrary Char where     arbitrary = arbitraryChar+instance Arbitrary (CountOf ty) where+    arbitrary = CountOf <$> arbitrary  instance Arbitrary Bool where     arbitrary = flip testBit 0 <$> (arbitraryPrimtype :: Gen Word)

@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+module Foundation.Check.Config+    ( Config(..)+    , Seed+    , DisplayOption(..)+    , defaultConfig+    , parseArgs+    , configHelp+    ) where++import           Foundation.Primitive.Imports+import           Foundation.Primitive.IntegralConv+import           Foundation.String.Read+import           Foundation.Check.Gen++type Seed = Word64++data DisplayOption =+      DisplayTerminalErrorOnly+    | DisplayGroupOnly+    | DisplayTerminalVerbose+    deriving (Eq, Ord, Enum, Bounded, Show)++data Config = Config+    { udfSeed      :: Maybe Seed -- ^ optional user specified seed+    , getGenParams :: !GenParams+        -- ^ Parameters for the generator+        --+        -- default:+        --   * 32bits long numbers;+        --   * array of 512 elements max;+        --   * string of 8192 bytes max.+        --+    , numTests     :: !Word64+        -- ^ the number of tests to perform on every property.+        --+        -- default: 100+    , listTests      :: Bool+    , testNameMatch  :: [String]+    , displayOptions :: !DisplayOption+    , helpRequested  :: Bool+    }++-- | create the default configuration+--+-- see @Config@ for details+defaultConfig :: Config+defaultConfig = Config+    { udfSeed      = Nothing+    , getGenParams = params+    , numTests     = 100+    , listTests    = False+    , testNameMatch  = []+    , displayOptions = DisplayGroupOnly+    , helpRequested  = False+    }+  where+    params = GenParams+        { genMaxSizeIntegral = 32   -- 256 bits maximum numbers+        , genMaxSizeArray    = 512  -- 512 elements+        , genMaxSizeString   = 8192 -- 8K string+        }++type ParamError = String++getInteger :: String -> String -> Either ParamError Integer+getInteger optionName s =+    maybe (Left errMsg) Right $ readIntegral s+  where+    errMsg = "argument error for " <> optionName <> " expecting a number but got : " <> s++parseArgs :: [String] -> Config -> Either ParamError Config+parseArgs []                cfg   = Right cfg+parseArgs ("--seed":[])    _      = Left "option `--seed' is missing a parameter"+parseArgs ("--seed":x:xs)  cfg    = getInteger "seed" x >>= \i -> parseArgs xs $ cfg { udfSeed = Just $ integralDownsize i }+parseArgs ("--tests":[])   _      = Left "option `--tests' is missing a parameter"+parseArgs ("--tests":x:xs) cfg    = getInteger "tests" x >>= \i -> parseArgs xs $ cfg { numTests = integralDownsize i }+parseArgs ("--quiet":xs)   cfg    = parseArgs xs $ cfg { displayOptions = DisplayTerminalErrorOnly }+parseArgs ("--list-tests":xs) cfg = parseArgs xs $ cfg { listTests = True }+parseArgs ("--verbose":xs) cfg    = parseArgs xs $ cfg { displayOptions = DisplayTerminalVerbose }+parseArgs ("--help":xs)    cfg    = parseArgs xs $ cfg { helpRequested = True }+parseArgs (x:xs)           cfg    = parseArgs xs $ cfg { testNameMatch = x : testNameMatch cfg }++configHelp :: [String]+configHelp =+    [ "Usage: <program-name> [options] [test-name-match]\n"+    , "\n"+    , "Known options:\n"+    , "\n"+    , "  --seed <seed>: a 64bit positive number to use as seed to generate arbitrary value.\n"+    , "  --tests <tests>: the number of tests to perform for every property tests.\n"+    , "  --quiet: print only the errors to the standard output\n"+    , "  --verbose: print every property tests to the stand output.\n"+    , "  --list-tests: print all test names.\n"+    ]

@@ -6,6 +6,7 @@     ( Gen     , runGen     , GenParams(..)+    , GenRng     , genRng     , genWithRng     , genWithParams

@@ -0,0 +1,287 @@+-- |+-- Module      : Foundation.Check.Main+-- License     : BSD-style+-- Maintainer  : Foundation maintainers+--+-- An application to check that integrate with the .cabal test-suite+--+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+module Foundation.Check.Main+    ( defaultMain+    ) where++import           Foundation.Primitive.Imports+import           Foundation.Primitive.IntegralConv+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.System.Info (os, OS(..))+import           Foundation.Collection+import           Foundation.Numerical+import           Foundation.IO.Terminal+import           Foundation.Check (iterateProperty)+import           Foundation.Check.Gen+import           Foundation.Check.Property+import           Foundation.Check.Config+import           Foundation.Check.Types+import           Foundation.List.DList+import           Foundation.Random+import           Foundation.Monad+import           Foundation.Monad.State+import           Control.Monad (when)+import           Data.Maybe (catMaybes)++nbFail :: TestResult -> HasFailures+nbFail (PropertyResult _ _ (PropertyFailed _)) = 1+nbFail (PropertyResult _ _ PropertySuccess)    = 0+nbFail (GroupResult    _ t _ _)                = t++nbTests :: TestResult -> CountOf TestResult+nbTests (PropertyResult _ t _) = t+nbTests (GroupResult _ _ t _)  = t++data TestState = TestState+    { config      :: !Config+    , getSeed     :: !Seed+    , indent      :: !(CountOf Char)+    , testPassed  :: !Word+    , testFailed  :: !Word+    , testPath    :: !(DList String)+    }++newState :: Config -> Seed -> TestState+newState cfg initSeed = TestState+    { testPath     = mempty+    , testPassed   = 0+    , testFailed   = 0+    , indent       = 0+    , getSeed      = initSeed+    , config       = cfg+    }++filterTestMatching :: Config -> Test -> Maybe Test+filterTestMatching cfg testRoot+    | null (testNameMatch cfg) = Just testRoot+    | otherwise                = testFilter [] testRoot+  where+    match acc s = or $ fmap (flip isInfixOf currentTestName) $ testNameMatch cfg+      where currentTestName = fqTestName (s:acc)+    or [] = False+    or (x:xs)+        | x == True = True+        | otherwise = or xs++    testFilter acc x =+        case x of+            Group s l    ->+                let filtered = catMaybes $ fmap (testFilter (s:acc)) l+                 in if null filtered then Nothing else Just (Group s filtered)+            CheckPlan s _+                | match acc s -> Just x+                | otherwise   -> Nothing+            Unit s _+                | match acc s -> Just x+                | otherwise   -> Nothing+            Property s _+                | match acc s -> Just x+                | otherwise   -> Nothing++-- | Run tests+defaultMain :: Test -> IO ()+defaultMain allTestRoot = do+    -- parse arguments+    ecfg <- flip parseArgs defaultConfig <$> getArgs+    cfg  <- case ecfg of+            Left e  -> do+                putStrLn e+                mapM_ putStrLn configHelp+                exitFailure+            Right c -> pure c++    -- use the user defined seed or generate a new seed+    seed <- maybe getRandomPrimType pure $ udfSeed cfg++    let testState = newState cfg seed++    when (helpRequested cfg) (mapM_ putStrLn configHelp >> exitSuccess)+    when (listTests cfg) (printTestName >> exitSuccess)++    putStrLn $ "\nSeed: " <> show seed <> "\n"++    case filterTestMatching cfg allTestRoot of+        Nothing -> putStrLn "no tests to run" >> exitSuccess+        Just t  -> do+            (_, cfg') <- runStateT (runCheckMain $ test t) testState+            summary cfg'++  where+    -- display a summary of the result and use the right exit code+    summary cfg+        | kos > 0 = do+            putStrLn $ "Failed " <> show kos <> " out of " <> show tot+            exitFailure+        | otherwise = do+            putStrLn $ "Succeed " <> show oks <> " test(s)"+            exitSuccess+      where+        oks = testPassed cfg+        kos = testFailed cfg+        tot = oks + kos++    -- print all the tests recursively+    printTestName = mapM_ (\tst -> putStrLn (fqTestName tst)) $ testCases [] [] [] allTestRoot+      where+        testCases acc xs pre x =+            case x of+                Group s l     -> tToList (fmap (\z -> (z, pre)) xs <> acc) (s:pre) l+                CheckPlan s _ -> (s : pre) : tToList acc pre xs+                Unit s _      -> (s : pre) : tToList acc pre xs+                Property s _  -> (s : pre) : tToList acc pre xs++        tToList []           _   []              = []+        tToList ((a,pre):as) _   []              = testCases as [] pre a+        tToList acc          pre (x:xs)          = testCases acc xs pre x++-- | internal check monad for facilitating the tests traversal+newtype CheckMain a = CheckMain { runCheckMain :: StateT TestState IO a }+  deriving (Functor, Applicative, Monad, MonadIO)++instance MonadState CheckMain where+    type State CheckMain = TestState+    withState = CheckMain . withState++onDisplayOption :: DisplayOption -> CheckMain () -> CheckMain ()+onDisplayOption opt chk = do+    on <- (<=) opt . displayOptions . config <$> get+    if on then chk else return ()++whenErrorOnly :: CheckMain () -> CheckMain ()+whenErrorOnly = onDisplayOption DisplayTerminalErrorOnly++whenGroupOnly :: CheckMain () -> CheckMain ()+whenGroupOnly = onDisplayOption DisplayGroupOnly++whenVerbose :: CheckMain () -> CheckMain ()+whenVerbose = onDisplayOption DisplayTerminalVerbose++passed :: CheckMain ()+passed = withState $ \s -> ((), s { testPassed = testPassed s + 1 })++failed :: CheckMain ()+failed = withState $ \s -> ((), s { testFailed = testFailed s + 1 })++test :: Test -> CheckMain TestResult+test (Group s l) = pushGroup s l+test (Unit _ _) = undefined+test (CheckPlan name plan) = do+    r <- testCheckPlan name plan+    return r+test (Property name prop) = do+    r'@(PropertyResult _ nb r) <- testProperty name (property prop)+    case r of+        PropertySuccess  -> whenVerbose $ displayPropertySucceed name nb+        PropertyFailed w -> whenErrorOnly $ displayPropertyFailed name nb w+    return r'++displayCurrent :: String -> CheckMain ()+displayCurrent name = do+    i <- indent <$> get+    liftIO $ putStrLn $ replicate i ' ' <> name++displayPropertySucceed :: String -> CountOf TestResult -> CheckMain ()+displayPropertySucceed name (CountOf nb) = do+    i <- indent <$> get+    liftIO $ putStrLn $ mconcat+        [ replicate i ' '+        , successString, name+        , " ("+        , show nb+        , if nb == 1 then " test)" else " tests)"+        ]++successString :: String+successString = case os of+    Right Linux -> " ✓ "+    Right OSX   -> " ✓ "+    _           -> "[SUCCESS]"+{-# NOINLINE successString #-}++failureString :: String+failureString = case os of+    Right Linux -> " ✗ "+    Right OSX   -> " ✗ "+    _           -> "[ ERROR ]"+{-# NOINLINE failureString #-}++displayPropertyFailed :: String -> CountOf TestResult -> String -> CheckMain ()+displayPropertyFailed name (CountOf nb) w = do+    seed <- getSeed <$> get+    i <- indent <$> get+    liftIO $ do+        putStrLn $ mconcat+          [ replicate i ' '+          , failureString, name+          , " failed after "+          , show nb+          , if nb == 1 then " test" else " tests:"+          ]+        putStrLn $ replicate i ' ' <> "   use param: --seed " <> show seed+        putStrLn w++pushGroup :: String -> [Test] -> CheckMain TestResult+pushGroup name list = do+    whenGroupOnly $ if groupHasSubGroup list then displayCurrent name else return ()+    withState $ \s -> ((), s { testPath = push (testPath s) name, indent = indent s + 2 })+    results <- mapM test list+    withState $ \s -> ((), s { testPath = pop (testPath s), indent = indent s - 2 })+    let totFail = sum $ fmap nbFail results+        tot = sum $ fmap nbTests results+    whenGroupOnly $ case (groupHasSubGroup list, totFail) of+        (True, _)              -> return ()+        (False, n) | n > 0     -> displayPropertyFailed name n ""+                   | otherwise -> displayPropertySucceed name tot+    return $ GroupResult name totFail tot results+  where+    sum = foldl' (+) 0+    push = snoc+    pop = maybe mempty fst . unsnoc++testCheckPlan :: String -> Check () -> CheckMain TestResult+testCheckPlan name actions = do+    seed <- getSeed <$> get+    path <- testPath <$> get+    params <- getGenParams . config <$> get+    let rngIt = genRng seed (name : toList path)++    let planState = PlanState { planRng         = rngIt+                              , planValidations = 0+                              , planParams      = params+                              , planFailures    = []+                              }+    st <- liftIO (snd <$> runStateT (runCheck actions) planState)+    let fails = planFailures st+    if null fails+        then return (GroupResult name 0 (planValidations st) [])+        else do+            displayCurrent name+            forM_ fails $ \f ->+                liftIO $ putStrLn $ show f+            return (GroupResult name (length fails) (planValidations st) fails)++testProperty :: String -> Property -> CheckMain TestResult+testProperty name prop = do+    seed <- getSeed <$> get+    path <- testPath <$> get+    let rngIt = genRng seed (name : toList path)++    params <- getGenParams . config <$> get+    maxTests <- numTests . config <$> get++    (res,nb) <- liftIO $ iterateProperty (CountOf $ integralDownsize (integralCast maxTests :: Int64)) params rngIt prop+    case res of+        PropertyFailed {} -> failed+        PropertySuccess   -> passed+    return (PropertyResult name nb res)

@@ -0,0 +1,82 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE FlexibleContexts           #-}+module Foundation.Check.Print+    ( propertyToResult+    , PropertyResult(..)+    , diffBlame+    ) where++import           Foundation.Check.Property+import           Foundation.Check.Types+import           Foundation.Primitive.Imports+import           Foundation.Collection+import           Foundation.Class.Bifunctor (bimap)+import           Foundation.Numerical++propertyToResult :: PropertyTestArg -> (PropertyResult, Bool)+propertyToResult propertyTestArg =+        let args   = propertyGetArgs propertyTestArg+            checks = getChecks propertyTestArg+         in if checkHasFailed checks+                then printError args checks+                else (PropertySuccess, length args > 0)+  where+    printError args checks = (PropertyFailed (mconcat $ loop 1 args), False)+      where+        loop :: Word -> [String] -> [String]+        loop _ []      = printChecks checks+        loop !i (a:as) = "parameter " <> show i <> " : " <> a <> "\n" : loop (i+1) as+    printChecks (PropertyBinaryOp True _ _ _)     = []+    printChecks (PropertyBinaryOp False n a b) =+        [ "Property `a " <> n <> " b' failed where:\n"+        , "    a = " <> a <> "\n"+        , "        " <> bl1 <> "\n"+        , "    b = " <> b <> "\n"+        , "        " <> bl2 <> "\n"+        ]+      where+        (bl1, bl2) = diffBlame a b+    printChecks (PropertyNamed True _)            = []+    printChecks (PropertyNamed False e)           = ["Property " <> e <> " failed"]+    printChecks (PropertyBoolean True)            = []+    printChecks (PropertyBoolean False)           = ["Property failed"]+    printChecks (PropertyFail _ e)                = ["Property failed: " <> e]+    printChecks (PropertyAnd True _ _)            = []+    printChecks (PropertyAnd False a1 a2) =+            [ "Property `cond1 && cond2' failed where:\n"+            , "   cond1 = " <> h1 <> "\n"++            ]+            <> ((<>) "           " <$>  hs1)+            <>+            [ "   cond2 = " <> h2 <> "\n"+            ]+            <> ((<>) "           " <$> hs2)+      where+        (h1, hs1) = f a1+        (h2, hs2) = f a2+        f a = case printChecks a of+                      [] -> ("Succeed", [])+                      (x:xs) -> (x, xs)++    propertyGetArgs (PropertyArg a p) = a : propertyGetArgs p+    propertyGetArgs (PropertyEOA _) = []++    getChecks (PropertyArg _ p) = getChecks p+    getChecks (PropertyEOA c  ) = c++diffBlame :: String -> String -> (String, String)+diffBlame a b = bimap fromList fromList $ go ([], []) (toList a) (toList b)+  where+    go (acc1, acc2) [] [] = (acc1, acc2)+    go (acc1, acc2) l1 [] = (acc1 <> blaming (length l1), acc2)+    go (acc1, acc2) [] l2 = (acc1                       , acc2 <> blaming (length l2))+    go (acc1, acc2) (x:xs) (y:ys)+        | x == y    = go (acc1 <> " ", acc2 <> " ") xs ys+        | otherwise = go (acc1 <> "^", acc2 <> "^") xs ys+    blaming n = replicate n '^'

@@ -27,11 +27,12 @@ type PropertyTestResult = Bool  -- | The type of check this test did for a property-data PropertyCheck = PropertyBoolean  PropertyTestResult-                   | PropertyNamed    PropertyTestResult String-                   | PropertyBinaryOp PropertyTestResult String String String-                   | PropertyAnd      PropertyTestResult PropertyCheck PropertyCheck-                   | PropertyFail     PropertyTestResult String+data PropertyCheck =+      PropertyBoolean  PropertyTestResult+    | PropertyNamed    PropertyTestResult String+    | PropertyBinaryOp PropertyTestResult String String String+    | PropertyAnd      PropertyTestResult PropertyCheck PropertyCheck+    | PropertyFail     PropertyTestResult String  checkHasSucceed :: PropertyCheck -> PropertyTestResult checkHasSucceed (PropertyBoolean b)        = b@@ -63,6 +64,7 @@ instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where     property p = forAll arbitrary p +-- | Running a generator for a specific type under a property forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property forAll generator tst = Prop $ do     a <- generator@@ -70,6 +72,7 @@   where     augment a arg = PropertyArg (show a) arg +-- | A property that check for equality of its 2 members. (===) :: (Show a, Eq a, Typeable a) => a -> a -> PropertyCheck (===) a b =     let sa = pretty a Proxy@@ -80,6 +83,9 @@ pretty :: (Show a, Typeable a) => a -> Proxy a -> String pretty a pa = show a <> " :: " <> show (typeRep pa) +-- | A property that check for a specific comparaison of its 2 members.+--+-- This is equivalent to `===` but with `compare` propertyCompare :: (Show a, Typeable a)                 => String           -- ^ name of the function used for comparaison, e.g. (<)                 -> (a -> a -> Bool) -- ^ function used for value comparaison@@ -91,6 +97,7 @@         sb = pretty b Proxy      in PropertyBinaryOp (a `op` b) name sa sb +-- | A conjuctive property composed of 2 properties that need to pass propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck propertyAnd c1 c2 =     PropertyAnd (checkHasSucceed c1 && checkHasSucceed c2) c1 c2

@@ -0,0 +1,86 @@+-- |+-- Module      : Foundation.Check.Types+-- License     : BSD-style+-- Maintainer  : Foundation maintainers+--+-- A implementation of a test framework+-- and property expression & testing+--+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Foundation.Check.Types+    ( Test(..)+    , testName+    , fqTestName+    , groupHasSubGroup+    , Check(..)+    , PlanState(..)+    , PropertyResult(..)+    , TestResult(..)+    , HasFailures+    ) where++import           Foundation.Primitive.Imports+import           Foundation.Collection+import           Foundation.Monad.State+import           Foundation.Check.Property+import           Foundation.Check.Gen++-- | Result of a property run+data PropertyResult =+      PropertySuccess+    | PropertyFailed  String+    deriving (Show,Eq)++-- | Name of a test Followed+data TestResult =+      PropertyResult String HasTests       PropertyResult+    | GroupResult    String HasFailures HasTests [TestResult]+    deriving (Show)++-- | number of tests and failures+type HasTests    = CountOf TestResult+type HasFailures = CountOf TestResult++data PlanState = PlanState+    { planRng         :: Word64 -> GenRng+    , planValidations :: CountOf TestResult+    , planParams      :: GenParams+    , planFailures    :: [TestResult]+    }++newtype Check a = Check { runCheck :: StateT PlanState IO a }+    deriving (Functor, Applicative, Monad)+instance MonadState Check where+    type State Check = PlanState+    withState f = Check (withState f)++-- | different type of tests supported+data Test where+    -- Unit test+    Unit      :: String -> IO () -> Test+    -- Property test+    Property  :: IsProperty prop => String -> prop -> Test+    -- Multiples tests grouped together+    Group     :: String -> [Test] -> Test+    -- Check plan+    CheckPlan :: String -> Check () -> Test++-- | Name of a test+testName :: Test -> String+testName (Unit s _)     = s+testName (Property s _) = s+testName (Group s _)    = s+testName (CheckPlan s _) = s++fqTestName :: [String] -> String+fqTestName = intercalate "/" . reverse++groupHasSubGroup :: [Test] -> Bool+groupHasSubGroup [] = False+groupHasSubGroup (Group{}:_) = True+groupHasSubGroup (_:xs) = groupHasSubGroup xs

@@ -55,13 +55,13 @@ -- in a structure. -- class Storable a => StorableFixed a where-    size :: proxy a -> Size Word8-    alignment :: proxy a -> Size Word8+    size :: proxy a -> CountOf Word8+    alignment :: proxy a -> CountOf Word8 -plusPtr :: StorableFixed a => Ptr a -> Size a -> Ptr a-plusPtr ptr (Size num) = ptr `Foreign.Ptr.plusPtr` (num * (size ptr `align` alignment ptr))+plusPtr :: StorableFixed a => Ptr a -> CountOf a -> Ptr a+plusPtr ptr (CountOf num) = ptr `Foreign.Ptr.plusPtr` (num * (size ptr `align` alignment ptr))   where-    align (Size sz) (Size a) = sz + (sz `mod` a)+    align (CountOf sz) (CountOf a) = sz + (sz `mod` a)  -- | like `peek` but at a given offset. peekOff :: StorableFixed a => Ptr a -> Offset a -> IO a@@ -72,8 +72,8 @@ pokeOff ptr off = poke (ptr `plusPtr` offsetAsSize off)  peekArray :: (Buildable col, StorableFixed (Element col))-          => Size (Element col) -> Ptr (Element col) -> IO col-peekArray (Size s) = build 64 . builder 0+          => CountOf (Element col) -> Ptr (Element col) -> IO col+peekArray (CountOf s) = build 64 . builder 0   where     builder off ptr       | off == s = return ()@@ -105,7 +105,7 @@                  => Element col -> Ptr (Element col) -> col -> IO () pokeArrayEndedBy term ptr col = do     pokeArray ptr col-    pokeOff ptr (Offset $ length col) term+    pokeOff ptr (sizeAsOffset $ length col) term  instance Storable CChar where     peek (Ptr addr) = primAddrRead addr (Offset 0)

@@ -52,7 +52,7 @@     append :: (PrimMonad prim) => Element col -> Builder col (Mutable col) (Step col) prim ()      build :: (PrimMonad prim)-          => Int -- ^ Size of a chunk+          => Int -- ^ CountOf of a chunk           -> Builder col (Mutable col) (Step col) prim ()           -> prim col 

@@ -29,6 +29,7 @@     ) where  import           Foundation.Internal.Base+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection.Element import qualified Data.List import qualified Foundation.Primitive.Block as BLK@@ -73,8 +74,10 @@     {-# MINIMAL null, length, (elem | notElem), minimum, maximum, all, any #-}     -- | Check if a collection is empty     null :: c -> Bool+     -- | Length of a collection (number of Element c)-    length :: c -> Int+    length :: c -> CountOf (Element c)+     -- | Check if a collection contains a specific element     --     -- This is the inverse of `notElem`.@@ -99,7 +102,7 @@  instance Collection [a] where     null = Data.List.null-    length = Data.List.length+    length = CountOf . Data.List.length      elem = Data.List.elem     notElem = Data.List.notElem@@ -131,7 +134,7 @@ instance Collection (BA.Array ty) where     null = BA.null     length = BA.length-    elem e = Data.List.elem e . toList+    elem = BA.elem     minimum = Data.List.minimum . toList . getNonEmpty -- TODO     maximum = Data.List.maximum . toList . getNonEmpty -- TODO     all p = Data.List.all p . toList

@@ -36,11 +36,11 @@  instance UV.PrimType ty => IndexedCollection (BLK.Block ty) where     (!) l n-        | A.isOutOfBound n (BLK.lengthSize l) = Nothing+        | A.isOutOfBound n (BLK.length l) = Nothing         | otherwise                           = Just $ BLK.index l n     findIndex predicate c = loop 0       where-        !len = BLK.lengthSize c+        !len = BLK.length c         loop i             | i .==# len                      = Nothing             | predicate (BLK.unsafeIndex c i) = Just i@@ -48,11 +48,11 @@  instance UV.PrimType ty => IndexedCollection (UV.UArray ty) where     (!) l n-        | A.isOutOfBound n (UV.lengthSize l) = Nothing+        | A.isOutOfBound n (UV.length l) = Nothing         | otherwise                          = Just $ UV.index l n     findIndex predicate c = loop 0       where-        !len = UV.lengthSize c+        !len = UV.length c         loop i             | i .==# len                     = Nothing             | predicate (UV.unsafeIndex c i) = Just i@@ -60,11 +60,11 @@  instance IndexedCollection (BA.Array ty) where     (!) l n-        | A.isOutOfBound n (BA.lengthSize l) = Nothing+        | A.isOutOfBound n (BA.length l) = Nothing         | otherwise                          = Just $ BA.index l n     findIndex predicate c = loop 0       where-        !len = BA.lengthSize c+        !len = BA.length c         loop i             | i .==# len = Nothing             | otherwise  =

@@ -65,8 +65,8 @@ -- | Evaluate each action in the collection from left to right, and -- ignore the results. For a version that doesn't ignore the results -- see 'Foundation.Collection.sequenceA'.-sequenceA_ :: (Mappable col, Applicative f) => col (f a) -> f ()-sequenceA_ col = sequenceA col *> pure ()+--sequenceA_ :: (Mappable col, Applicative f) => col (f a) -> f ()+--sequenceA_ col = sequenceA col *> pure ()  -- | Map each element of a collection to a monadic action, evaluate -- these actions from left to right, and ignore the results. For a

@@ -13,7 +13,6 @@ import           Foundation.Primitive.Types.OffsetSize import qualified Foundation.Primitive.Block         as BLK import qualified Foundation.Primitive.Block.Mutable as BLK-import           Foundation.Internal.Base  import qualified Foundation.Array.Unboxed.Mutable as MUV import qualified Foundation.Array.Unboxed as UV@@ -35,7 +34,7 @@     thaw   :: PrimMonad prim => MutableFreezed c -> prim (c (PrimState prim))     freeze :: PrimMonad prim => c (PrimState prim) -> prim (MutableFreezed c) -    mutNew :: PrimMonad prim => Int -> prim (c (PrimState prim))+    mutNew :: PrimMonad prim => CountOf (MutableValue c) -> prim (c (PrimState prim))      mutUnsafeWrite :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> MutableValue c -> prim ()     mutWrite       :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> MutableValue c -> prim ()@@ -52,7 +51,7 @@     unsafeThaw = UV.unsafeThaw     unsafeFreeze = UV.unsafeFreeze -    mutNew i = MUV.new (Size i)+    mutNew = MUV.new      mutUnsafeWrite = MUV.unsafeWrite     mutUnsafeRead = MUV.unsafeRead@@ -69,7 +68,7 @@     unsafeThaw = BLK.unsafeThaw     unsafeFreeze = BLK.unsafeFreeze -    mutNew i = BLK.new (Size i)+    mutNew = BLK.new      mutUnsafeWrite = BLK.unsafeWrite     mutUnsafeRead = BLK.unsafeRead@@ -86,7 +85,7 @@     unsafeThaw = BA.unsafeThaw     unsafeFreeze = BA.unsafeFreeze -    mutNew n = BA.new (Size n)+    mutNew = BA.new     mutUnsafeWrite = BA.unsafeWrite     mutUnsafeRead = BA.unsafeRead     mutWrite = BA.write

@@ -17,7 +17,7 @@     ) where  import           Foundation.Internal.Base-import           Foundation.Primitive.IntegralConv+import           Foundation.Numerical.Subtractive import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection.Element import           Foundation.Collection.Collection@@ -42,27 +42,27 @@               #-}      -- | Take the first @n elements of a collection-    take :: Int -> c -> c+    take :: CountOf (Element c) -> c -> c     take n = fst . splitAt n      -- | Take the last @n elements of a collection-    revTake :: Int -> c -> c+    revTake :: CountOf (Element c) -> c -> c     revTake n = fst . revSplitAt n      -- | Drop the first @n elements of a collection-    drop :: Int -> c -> c+    drop :: CountOf (Element c) -> c -> c     drop n = snd . splitAt n      -- | Drop the last @n elements of a collection-    revDrop :: Int -> c -> c+    revDrop :: CountOf (Element c) -> c -> c     revDrop n = snd . revSplitAt n      -- | Split the collection at the @n'th elements-    splitAt :: Int -> c -> (c,c)+    splitAt :: CountOf (Element c) -> c -> (c,c)     splitAt n c = (take n c, drop n c)      -- | Split the collection at the @n'th elements from the end-    revSplitAt :: Int -> c -> (c,c)+    revSplitAt :: CountOf (Element c) -> c -> (c,c)     revSplitAt n c = (revTake n c, revDrop n c)      -- | Split on a specific elements returning a list of colletion@@ -143,7 +143,7 @@     init nel = maybe (error "init") fst $ unsnoc (getNonEmpty nel)      -- | Create a collection where the element in parameter is repeated N time-    replicate :: Word -> Element c -> c+    replicate :: CountOf (Element c) -> Element c -> c      -- | Takes two collections and returns True iff the first collection is a prefix of the second.     isPrefixOf :: Eq (Element c) => c -> c -> Bool@@ -167,17 +167,34 @@         len1 = length c1         len2 = length c2 +    -- | Takes two collections and returns True iff the first collection is an infix of the second.+    isInfixOf :: Eq (Element c) => c -> c -> Bool+    default isInfixOf :: Eq c => c -> c -> Bool+    isInfixOf c1 c2+        | len1 > len2  = False+        | otherwise    = loop 0+      where+        endofs = len2 - len1+        len1 = length c1+        len2 = length c2++        loop i+            | i == endofs = c1 == c2Sub+            | c1 == c2Sub = True+            | otherwise   = loop (succ i)+          where c2Sub = take len1 $ drop i $ c2+ -- Temporary utility functions mconcatCollection :: (Monoid (Item c), Sequential c) => c -> Element c mconcatCollection c = mconcat (toList c)  instance Sequential [a] where-    take = Data.List.take-    drop = Data.List.drop-    revTake = ListExtra.revTake-    revDrop = ListExtra.revDrop-    splitAt = Data.List.splitAt-    revSplitAt = ListExtra.revSplitAt+    take (CountOf n) = Data.List.take n+    drop (CountOf n) = Data.List.drop n+    revTake (CountOf n) = ListExtra.revTake n+    revDrop (CountOf n) = ListExtra.revDrop n+    splitAt (CountOf n) = Data.List.splitAt n+    revSplitAt (CountOf n) = ListExtra.revSplitAt n     splitOn = ListExtra.wordsWhen     break = Data.List.break     intersperse = Data.List.intersperse@@ -192,13 +209,13 @@     find = Data.List.find     sortBy = Data.List.sortBy     singleton = (:[])-    replicate i = Data.List.replicate (wordToInt i)+    replicate (CountOf i) = Data.List.replicate i     isPrefixOf = Data.List.isPrefixOf     isSuffixOf = Data.List.isSuffixOf  instance UV.PrimType ty => Sequential (BLK.Block ty) where-    splitAt n = BLK.splitAt (Size n)-    revSplitAt n = BLK.revSplitAt (Size n)+    splitAt n = BLK.splitAt n+    revSplitAt n = BLK.revSplitAt n     splitOn = BLK.splitOn     break = BLK.break     intersperse = BLK.intersperse@@ -281,3 +298,6 @@     sortBy = S.sortBy     singleton = S.singleton     replicate = S.replicate+    isSuffixOf = S.isSuffixOf+    isPrefixOf = S.isPrefixOf+    isInfixOf  = S.isInfixOf

@@ -1,5 +1,6 @@ module Foundation.Conduit.Textual     ( lines+    , words     , fromBytes     , toBytes     ) where@@ -11,6 +12,7 @@ import qualified Foundation.String.UTF8 as S import           Foundation.Conduit.Internal import           Foundation.Monad+import           Data.Char (isSpace)  -- | Split conduit of string to its lines --@@ -33,6 +35,22 @@                 let nextCurrent = nextBuf : prevs                  in await >>= maybe (finish nextCurrent) (go nextCurrent)       where (line, next') = S.breakElem '\n' nextBuf++words :: Monad m => Conduit String String m ()+words = await >>= maybe (finish []) (go [])+  where+    mconcatRev = mconcat . reverse++    finish l = if null l then return () else yield (mconcatRev l)++    go prevs nextBuf =+        case S.dropWhile isSpace next' of+            rest' +                | null rest' ->+                    let nextCurrent = nextBuf : prevs+                     in await >>= maybe (finish nextCurrent) (go nextCurrent)+                | otherwise  -> yield (mconcatRev (line : prevs)) >> go mempty rest'+      where (line, next') = S.break isSpace nextBuf  fromBytes :: MonadThrow m => S.Encoding -> Conduit (UArray Word8) String m () fromBytes encoding = loop mempty

@@ -0,0 +1,11 @@+{-# LANGUAGE MagicHash #-}+module Foundation.Foreign.Alloc+    ( allocaBytes+    ) where++import qualified Foreign.Marshal.Alloc as A (allocaBytes)+import           Foundation.Primitive.Imports+import           Foundation.Primitive.Types.OffsetSize++allocaBytes :: CountOf Word8 -> (Ptr a -> IO b) -> IO b+allocaBytes (CountOf i) f = A.allocaBytes i f

@@ -124,7 +124,7 @@     goVec :: ByteArray# -> Offset Word8 -> FNV1_32     goVec !ma !start = loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc)@@ -133,7 +133,7 @@     goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1_32     goAddr !(Ptr ptr) !start = return $ loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc)@@ -149,7 +149,7 @@     goVec :: ByteArray# -> Offset Word8 -> FNV1a_32     goVec !ma !start = loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc)@@ -158,7 +158,7 @@     goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1a_32     goAddr !(Ptr ptr) !start = return $ loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc)@@ -174,7 +174,7 @@     goVec :: ByteArray# -> Offset Word8 -> FNV1_64     goVec !ma !start = loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc)@@ -183,7 +183,7 @@     goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1_64     goAddr !(Ptr ptr) !start = return $ loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc)@@ -199,7 +199,7 @@     goVec :: ByteArray# -> Offset Word8 -> FNV1a_64     goVec !ma !start = loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc)@@ -208,7 +208,7 @@     goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1a_64     goAddr !(Ptr ptr) !start = return $ loop start initialState       where-        !len = start `offsetPlusE` A.lengthSize ba+        !len = start `offsetPlusE` A.length ba         loop !idx !acc             | idx >= len = acc             | otherwise  = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc)

@@ -22,6 +22,7 @@ import           Foundation.Internal.Base import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Types+import           Foundation.Primitive.IntegralConv import           Foundation.Hashing.Hasher import qualified Foundation.Array.Unboxed as A import           Foundation.Array@@ -67,7 +68,7 @@     hashMix64 w (Sip1_3 st)     = Sip1_3 $ mix64 1 w st     hashMixBytes ba (Sip1_3 st) = Sip1_3 $ mixBa 1 ba st -data Sip = Sip !InternalState !SipIncremental !Word64+data Sip = Sip !InternalState !SipIncremental !(CountOf Word8)  data InternalState = InternalState {-# UNPACK #-} !Word64                                    {-# UNPACK #-} !Word64@@ -163,7 +164,7 @@     {-# INLINE consume #-}  finish :: Int -> Int -> Sip -> SipHash-finish !c !d (Sip ist incremental len) = finalize d $+finish !c !d (Sip ist incremental (CountOf len)) = finalize d $     case incremental of         SipIncremental0     -> process c ist lenMask         SipIncremental1 acc -> process c ist (lenMask .|. acc)@@ -174,14 +175,15 @@         SipIncremental6 acc -> process c ist (lenMask .|. acc)         SipIncremental7 acc -> process c ist (lenMask .|. acc)   where-    lenMask = (len .&. 0xff) .<<. 56+    lenMask = (wlen .&. 0xff) .<<. 56+    wlen = integralCast (integralUpsize len :: Int64) :: Word64  -- | same as 'hash', except also specifies the number of sipround iterations for compression (C) and digest (D). mixBa :: PrimType a => Int -> UArray a -> Sip -> Sip mixBa !c !array (Sip initSt initIncr currentLen) =     A.unsafeDewrap goVec goAddr array8   where-    totalLen = Prelude.fromIntegral $ A.length array8+    totalLen = A.length array8     array8 = A.unsafeRecast array      goVec :: ByteArray# -> Offset Word8 -> Sip

@@ -59,7 +59,7 @@ hGet :: Handle -> Int -> IO (UArray Word8) hGet h size     | size < 0   = invalidBufferSize "hGet" h size-    | otherwise  = V.createFromIO (Size size) $ \p -> (Size <$> S.hGetBuf h p size)+    | otherwise  = V.createFromIO (CountOf size) $ \p -> (CountOf <$> S.hGetBuf h p size)  -- | hGetNonBlocking is similar to 'hGet', except that it will never block -- waiting for data to become available, instead it returns only whatever data@@ -70,7 +70,7 @@ hGetNonBlocking :: Handle -> Int -> IO (UArray Word8) hGetNonBlocking h size     | size < 0  = invalidBufferSize "hGetNonBlocking" h size-    | otherwise = V.createFromIO (Size size) $ \p -> (Size <$> S.hGetBufNonBlocking h p size)+    | otherwise = V.createFromIO (CountOf size) $ \p -> (CountOf <$> S.hGetBufNonBlocking h p size)  -- | Like 'hGet', except that a shorter array may be returned -- if there are not enough bytes immediately available to satisfy the@@ -80,10 +80,10 @@ hGetSome :: Handle -> Int -> IO (UArray Word8) hGetSome h size     | size < 0  = invalidBufferSize "hGetSome" h size-    | otherwise = V.createFromIO (Size size) $ \p -> (Size <$> S.hGetBufSome h p size)+    | otherwise = V.createFromIO (CountOf size) $ \p -> (CountOf <$> S.hGetBufSome h p size)  hPut :: Handle -> (UArray Word8) -> IO ()-hPut h arr = withPtr arr $ \ptr -> S.hPutBuf h ptr (length arr)+hPut h arr = withPtr arr $ \ptr -> S.hPutBuf h ptr (let (CountOf sz) = length arr in sz)  invalidBufferSize :: [Char] -> Handle -> Int -> IO a invalidBufferSize functionName handle size =@@ -106,7 +106,7 @@     -- TODO filesize is an integer (whyyy ?!), and transforming to Int using     -- fromIntegral is probably the wrong thing to do here..     sz <- S.hFileSize h-    mv <- V.newPinned (Size $ fromInteger sz)+    mv <- V.newPinned (CountOf $ fromInteger sz)     V.withMutablePtr mv $ loop h (fromInteger sz)     unsafeFreeze mv   where@@ -126,7 +126,7 @@              -> FilePath              -- ^ File to read              -> IO a foldTextFile chunkf ini fp = do-    buf <- V.newPinned (Size blockSize)+    buf <- V.newPinned (CountOf blockSize)     V.withMutablePtr buf $ \ptr ->         withFile fp S.ReadMode $ doFold buf ptr   where@@ -136,9 +136,9 @@             r <- S.hGetBuf handle ptr blockSize             if r > 0 && r <= blockSize                 then do-                    (pos, validateRet) <- S.mutableValidate mv 0 (Size r)+                    (pos, validateRet) <- S.mutableValidate mv 0 (CountOf r)                     s <- case validateRet of-                        Nothing -> S.fromBytesUnsafe `fmap` V.freezeShrink mv (Size r)+                        Nothing -> S.fromBytesUnsafe `fmap` V.freezeShrink mv (CountOf r)                         Just S.MissingByte -> do                             sRet <- S.fromBytesUnsafe `fmap` V.freezeShrink mv (pos - 0)                             V.unsafeSlide mv pos (Offset r)

@@ -46,7 +46,7 @@ fileMapRead fp = do     fileMapping <- I.fileMapRead fp     fptr <- I.fileMappingToFinalPtr fileMapping-    return $ V.foreignMem fptr (getSize fileMapping)+    return $ V.foreignMem fptr (CountOf $ getSize fileMapping)  -- | Map in memory the whole content of a file, @@ -57,4 +57,4 @@ fileMapReadWith fp f = do     bracket (I.fileMapRead fp) I.fileMappingUnmap $ \fm -> do         fptr <- toFinalPtr (I.fileMappingPtr fm) (\_ -> return ())-        f (V.foreignMem fptr (getSize fm))+        f (V.foreignMem fptr (CountOf $ getSize fm))

@@ -10,11 +10,16 @@     , putStr     , stdin     , stdout+    , getArgs+    , exitFailure+    , exitSuccess     ) where  import           Foundation.Primitive.Imports import qualified Prelude import           System.IO (stdin, stdout)+import           System.Exit+import qualified System.Environment as SE (getArgs)  -- | Print a string to standard output putStr :: String -> IO ()@@ -23,3 +28,7 @@ -- | Print a string with a newline to standard output putStrLn :: String -> IO () putStrLn = Prelude.putStrLn . toList++-- | Get the arguments from the terminal command+getArgs :: IO [String]+getArgs = fmap fromList <$> SE.getArgs

@@ -9,7 +9,7 @@ module Foundation.Internal.PrimTypes     ( FileSize#     , Offset#-    , Size#+    , CountOf#     ) where  import GHC.Prim@@ -22,7 +22,7 @@ -- for code documentation purpose only, just a simple type alias on Int# type Offset# = Int# --- | Size in bytes type alias+-- | CountOf in bytes type alias -- -- for code documentation purpose only, just a simple type alias on Int#-type Size# = Int#+type CountOf# = Int#

@@ -4,7 +4,6 @@     ) where  import           Foundation.Internal.Base-import           Foundation.Numerical import qualified Prelude  -- | Method to support basic trigonometric functions

@@ -23,7 +23,7 @@     , ipv6ParserIpv4Embedded     ) where -import Prelude (fromIntegral, replicate, read)+import Prelude (fromIntegral, read) import qualified Text.Printf as Base import Data.Char (isHexDigit, isDigit) import Numeric (readHex)@@ -35,8 +35,9 @@ import Foundation.Internal.Base import Foundation.Internal.Proxy import Foundation.Primitive+import Foundation.Primitive.Types.OffsetSize import Foundation.Numerical-import Foundation.Collection (Sequential, Element, length, intercalate, null)+import Foundation.Collection (Sequential, Element, length, intercalate, replicate, null) import Foundation.Parser import Foundation.String (String) import Foundation.Bits@@ -206,7 +207,8 @@               takeAWord16 <* skipColon     _ <- optional skipColon     _ <- optional skipColon-    bs2 <- repeat (Between Never (toEnum $ 6 - length bs1)) $+    let (CountOf lenBs1) = length bs1+    bs2 <- repeat (Between Never (toEnum $ 6 - lenBs1)) $               takeAWord16 <* skipColon     _ <- optional skipColon     [i1,i2,i3,i4,i5,i6] <- format 6 bs1 bs2@@ -236,16 +238,18 @@     bs1 <- repeat (Between Never (toEnum 8)) $               takeAWord16 <* skipColon     when (null bs1) skipColon-    bs2 <- repeat (Between Never (toEnum $ 8 - length bs1)) $+    let (CountOf bs1Len) = length bs1+    bs2 <- repeat (Between Never (toEnum $ 8 - bs1Len)) $               skipColon *> takeAWord16     [i1,i2,i3,i4,i5,i6,i7,i8] <- format 8 bs1 bs2     return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8) -format :: (Integral a, Monad m) => Int -> [a] -> [a] -> m [a]-format sz bs1 bs2 = do-    let len = sz - length bs1 - length bs2-    when (len < 1) $ fail "invalid compressed IPv6 addressed"-    return $ bs1 <> replicate len 0 <> bs2+format :: (Integral a, Monad m) => CountOf a -> [a] -> [a] -> m [a]+format sz bs1 bs2+    | sz <= (length bs1 + length bs2) = fail "invalid compressed IPv6 addressed"+    | otherwise = do+        let len = sz `sizeSub` (length bs1 + length bs2)+        return $ bs1 <> replicate len 0 <> bs2  skipColon :: (Sequential input, Element input ~ Char)           => Parser input ()

@@ -1,13 +1,26 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE MagicHash         #-} module Foundation.Numerical.Additive     ( Additive(..)     ) where +#include "MachDeps.h"+ import           Foundation.Internal.Base import           Foundation.Internal.Natural import           Foundation.Numerical.Number import qualified Prelude+import           GHC.Types+import           GHC.Prim+import           GHC.Int+import           GHC.Word+import           Foreign.C.Types +#if WORD_SIZE_IN_BITS < 64+import           GHC.IntWord64+#endif+ -- | Represent class of things that can be added together, -- contains a neutral element and is commutative. --@@ -35,27 +48,31 @@     scale = scaleNum instance Additive Int where     azero = 0-    (+) = (Prelude.+)+    (I# a) + (I# b) = I# (a +# b)     scale = scaleNum instance Additive Int8 where     azero = 0-    (+) = (Prelude.+)+    (I8# a) + (I8# b) = I8# (narrow8Int# (a +# b))     scale = scaleNum instance Additive Int16 where     azero = 0-    (+) = (Prelude.+)+    (I16# a) + (I16# b) = I16# (narrow16Int# (a +# b))     scale = scaleNum instance Additive Int32 where     azero = 0-    (+) = (Prelude.+)+    (I32# a) + (I32# b) = I32# (narrow32Int# (a +# b))     scale = scaleNum instance Additive Int64 where     azero = 0-    (+) = (Prelude.+)+#if WORD_SIZE_IN_BITS == 64+    (I64# a) + (I64# b) = I64# (a +# b)+#else+    (I64# a) + (I64# b) = I64# (a `plusInt64#` b)+#endif     scale = scaleNum instance Additive Word where     azero = 0-    (+) = (Prelude.+)+    (W# a) + (W# b) = W# (a `plusWord#` b)     scale = scaleNum instance Additive Natural where     azero = 0@@ -63,26 +80,34 @@     scale = scaleNum instance Additive Word8 where     azero = 0-    (+) = (Prelude.+)+    (W8# a) + (W8# b) = W8# (narrow8Word# (a `plusWord#` b))     scale = scaleNum instance Additive Word16 where     azero = 0-    (+) = (Prelude.+)+    (W16# a) + (W16# b) = W16# (narrow16Word# (a `plusWord#` b))     scale = scaleNum instance Additive Word32 where     azero = 0-    (+) = (Prelude.+)+    (W32# a) + (W32# b) = W32# (narrow32Word# (a `plusWord#` b))     scale = scaleNum instance Additive Word64 where     azero = 0-    (+) = (Prelude.+)+#if WORD_SIZE_IN_BITS == 64+    (W64# a) + (W64# b) = W64# (a `plusWord#` b)+#else+    (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b))+#endif     scale = scaleNum instance Additive Prelude.Float where     azero = 0.0-    (+) = (Prelude.+)+    (F# a) + (F# b) = F# (a `plusFloat#` b)     scale = scaleNum instance Additive Prelude.Double where     azero = 0.0+    (D# a) + (D# b) = D# (a +## b)+    scale = scaleNum+instance Additive CSize where+    azero = 0     (+) = (Prelude.+)     scale = scaleNum 

@@ -6,6 +6,7 @@ import           Foundation.Internal.Base import           Foundation.Internal.Natural import qualified Prelude+import           Foreign.C.Types  -- | Number literals, convertible through the generic Integer type. --@@ -44,6 +45,8 @@     toInteger i = Prelude.toInteger i instance IsIntegral Word64 where     toInteger i = Prelude.toInteger i+instance IsIntegral CSize where+    toInteger i = Prelude.toInteger i  instance IsNatural Natural where     toNatural i = i@@ -56,4 +59,6 @@ instance IsNatural Word32 where     toNatural i = Prelude.fromIntegral i instance IsNatural Word64 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural CSize where     toNatural i = Prelude.fromIntegral i

@@ -49,6 +49,7 @@ import           Control.Applicative (Alternative, empty, (<|>), many, some, optional) import           Control.Monad       (MonadPlus, mzero, mplus) import           Foundation.Internal.Base+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection hiding (take) import           Foundation.String import           Foundation.Numerical@@ -258,7 +259,7 @@                    else err actual (Expected expected (fromBytesUnsafe eMatch))  -- | Take @n elements from the current position in the stream-take :: Sequential input => Int -> Parser input input+take :: Sequential input => CountOf (Element input) -> Parser input input take n = Parser $ \buf err ok ->     if length buf >= n         then let (b1,b2) = splitAt n buf in ok b2 b1@@ -289,11 +290,11 @@     returnBuffer = Parser $ \buf _ ok -> ok mempty buf  -- | Skip @n elements from the current position in the stream-skip :: Sequential input => Int -> Parser input ()+skip :: Sequential input => CountOf (Element input) -> Parser input () skip n = Parser $ \buf err ok ->     if length buf >= n         then ok (drop n buf) ()-        else runParser (getMore >> skip (n - length buf)) mempty err ok+        else runParser (getMore >> skip (n `sizeSub` length buf)) mempty err ok  -- | Skip `Element input` while the @predicate hold from the current position -- in the stream

@@ -7,7 +7,7 @@ -- very similar to an unboxed array but with the key difference: -- -- * It doesn't have slicing capability (no cheap take or drop)--- * It consume less memory: 1 Offset, 1 Size, 1 Pinning status trimmed+-- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed -- * It's unpackable in any constructor -- * It uses unpinned memory by default --@@ -19,7 +19,6 @@     , MutableBlock(..)     -- * Properties     , length-    , lengthSize     -- * Lowlevel functions     , unsafeThaw     , unsafeFreeze@@ -68,18 +67,12 @@ import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import           Foundation.Primitive.Exception-import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Types import qualified Foundation.Primitive.Block.Mutable as M import           Foundation.Primitive.Block.Mutable (Block(..), MutableBlock(..), new, unsafeThaw, unsafeFreeze) import           Foundation.Primitive.Block.Base import           Foundation.Numerical --- | return the number of elements of the array.-length :: PrimType ty => Block ty -> Int-length a = let (Size len) = lengthSize a in len-{-# INLINE[1] length #-}- -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim                 => Block ty -- ^ the source block to copy@@ -91,7 +84,7 @@ -- | Create a new array of size @n by settings each cells through the -- function @f. create :: forall ty . PrimType ty-       => Size ty           -- ^ the size of the block (in element of ty)+       => CountOf ty           -- ^ the size of the block (in element of ty)        -> (Offset ty -> ty) -- ^ the function that set the value at the index        -> Block ty          -- ^ the array created create n initializer@@ -104,8 +97,8 @@ singleton :: PrimType ty => ty -> Block ty singleton ty = create 1 (const ty) -replicate :: PrimType ty => Word -> ty -> Block ty-replicate sz ty = create (Size (integralCast sz)) (const ty)+replicate :: PrimType ty => CountOf ty -> ty -> Block ty+replicate sz ty = create sz (const ty)  -- | Thaw a Block into a MutableBlock --@@ -113,14 +106,14 @@ -- and its content is copied to the mutable block thaw :: (PrimMonad prim, PrimType ty) => Block ty -> prim (MutableBlock ty (PrimState prim)) thaw array = do-    ma <- M.unsafeNew (lengthBytes array)+    ma <- M.unsafeNew unpinned (lengthBytes array)     M.unsafeCopyBytesRO ma 0 array 0 (lengthBytes array)     return ma {-# INLINE thaw #-}  freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty) freeze ma = do-    ma' <- unsafeNew len+    ma' <- unsafeNew unpinned len     M.unsafeCopyBytes ma' 0 ma 0 len     --M.copyAt ma' (Offset 0) ma (Offset 0) len     unsafeFreeze ma'@@ -139,18 +132,18 @@     | isOutOfBound n len = outOfBound OOB_Index n len     | otherwise          = unsafeIndex array n   where-    !len = lengthSize array+    !len = length array {-# INLINE index #-}  -- | Map all element 'a' from a block to a new block of 'b' map :: (PrimType a, PrimType b) => (a -> b) -> Block a -> Block b map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))-  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (lengthSize a)+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a)  foldl :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a foldl f initialAcc vec = loop 0 initialAcc   where-    !len = lengthSize vec+    !len = length vec     loop i acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -158,7 +151,7 @@ foldr :: PrimType ty => (ty -> a -> a) -> a -> Block ty -> a foldr f initialAcc vec = loop 0   where-    !len = lengthSize vec+    !len = length vec     loop i         | i .==# len = initialAcc         | otherwise  = unsafeIndex vec i `f` loop (i+1)@@ -166,7 +159,7 @@ foldl' :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    !len = lengthSize vec+    !len = length vec     loop i !acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))@@ -180,37 +173,37 @@         M.unsafeWrite muv 0 e         unsafeFreeze muv   where-    !len = lengthSize vec+    !len = length vec  snoc :: PrimType ty => Block ty -> ty -> Block ty snoc vec e-    | len == Size 0 = singleton e+    | len == CountOf 0 = singleton e     | otherwise     = runST $ do         muv <- new (len + 1)         M.unsafeCopyElementsRO muv 0 vec 0 len-        M.unsafeWrite muv (0 `offsetPlusE` lengthSize vec) e+        M.unsafeWrite muv (0 `offsetPlusE` length vec) e         unsafeFreeze muv   where-     !len = lengthSize vec+     !len = length vec  sub :: PrimType ty => Block ty -> Offset ty -> Offset ty -> Block ty sub blk start end-    | start >= end = mempty-    | otherwise    = runST $ do+    | start >= end' = mempty+    | otherwise     = runST $ do         dst <- new newLen         M.unsafeCopyElementsRO dst 0 blk start newLen         unsafeFreeze dst   where     newLen = end' - start-    end' = min end (start `offsetPlusE` (end - start))-    !len = lengthSize blk+    end' = min (sizeAsOffset len) end+    !len = length blk  uncons :: PrimType ty => Block ty -> Maybe (ty, Block ty) uncons vec     | nbElems == 0 = Nothing     | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))   where-    !nbElems = lengthSize vec+    !nbElems = length vec  unsnoc :: PrimType ty => Block ty -> Maybe (Block ty, ty) unsnoc vec@@ -218,9 +211,9 @@     | otherwise    = Just (sub vec 0 lastElem, unsafeIndex vec lastElem)   where     !lastElem = 0 `offsetPlusE` (nbElems - 1)-    !nbElems = lengthSize vec+    !nbElems = length vec -splitAt :: PrimType ty => Size ty -> Block ty -> (Block ty, Block ty)+splitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty) splitAt nbElems blk     | nbElems <= 0 = (mempty, blk)     | n == vlen    = (blk, mempty)@@ -233,17 +226,17 @@         (,) <$> unsafeFreeze left <*> unsafeFreeze right   where     n    = min nbElems vlen-    vlen = lengthSize blk+    vlen = length blk -revSplitAt :: PrimType ty => Size ty -> Block ty -> (Block ty, Block ty)+revSplitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty) revSplitAt n blk     | n <= 0    = (mempty, blk)-    | otherwise = let (x,y) = splitAt (lengthSize blk - n) blk in (y,x)+    | otherwise = let (x,y) = splitAt (length blk - n) blk in (y,x)  break :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) break predicate blk = findBreak 0   where-    !len = lengthSize blk+    !len = length blk     findBreak !i         | i .==# len                    = (blk, mempty)         | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk@@ -256,7 +249,7 @@ elem :: PrimType ty => ty -> Block ty -> Bool elem v blk = loop 0   where-    !len = lengthSize blk+    !len = length blk     loop i         | i .==# len             = False         | unsafeIndex blk i == v = True@@ -265,7 +258,7 @@ all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool all p blk = loop 0   where-    !len = lengthSize blk+    !len = length blk     loop i         | i .==# len            = True         | p (unsafeIndex blk i) = loop (i+1)@@ -274,7 +267,7 @@ any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool any p blk = loop 0   where-    !len = lengthSize blk+    !len = length blk     loop i         | i .==# len            = False         | p (unsafeIndex blk i) = True@@ -285,7 +278,7 @@     | len == 0  = [mempty]     | otherwise = go 0 0   where-    !len = lengthSize blk+    !len = length blk     go !prevIdx !idx         | idx .==# len = [sub blk prevIdx idx]         | otherwise    =@@ -298,7 +291,7 @@ find :: PrimType ty => (ty -> Bool) -> Block ty -> Maybe ty find predicate vec = loop 0   where-    !len = lengthSize vec+    !len = length vec     loop i         | i .==# len = Nothing         | otherwise  =@@ -316,7 +309,7 @@         go mb         unsafeFreeze mb   where-    !len = lengthSize blk+    !len = length blk     !endOfs = 0 `offsetPlusE` len      go :: MutableBlock ty s -> ST s ()@@ -332,7 +325,7 @@     | len == 0  = mempty     | otherwise = runST (thaw vec >>= doSort xford)   where-    len = lengthSize vec+    len = length vec     doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MutableBlock ty (PrimState prim) -> prim (Block ty)     doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma       where@@ -372,7 +365,7 @@         go mb         unsafeFreeze mb   where-    !len = lengthSize blk+    !len = length blk     newSize = len + len - 1      go :: MutableBlock ty s -> ST s ()

@@ -16,18 +16,22 @@     , unsafeWrite     , unsafeIndex     -- * Properties-    , lengthSize+    , length     , lengthBytes     -- * Other methods     , new+    , newPinned     ) where  import           GHC.Prim import           GHC.Types import           GHC.ST+import           GHC.IO import qualified Data.List import           Foundation.Internal.Base import           Foundation.Internal.Proxy+import           Foundation.Internal.Primitive+import           Foundation.System.Bindings.Hs (sysHsMemcmpBaBa) import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import           Foundation.Primitive.NormalForm@@ -51,6 +55,7 @@ instance (PrimType ty, Show ty) => Show (Block ty) where     show v = show (toList v) instance (PrimType ty, Eq ty) => Eq (Block ty) where+    {-# SPECIALIZE instance Eq (Block Word8) #-}     (==) = equal instance (PrimType ty, Ord ty) => Ord (Block ty) where     compare = internalCompare@@ -65,15 +70,15 @@     fromList = internalFromList     toList = internalToList -lengthSize :: forall ty . PrimType ty => Block ty -> Size ty-lengthSize (Block ba) =-    let !(Size (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)+length :: forall ty . PrimType ty => Block ty -> CountOf ty+length (Block ba) =+    let !(CountOf (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)         !elems              = quotInt# (sizeofByteArray# ba) szBits-     in Size (I# elems)-{-# INLINE[1] lengthSize #-}+     in CountOf (I# elems)+{-# INLINE[1] length #-} -lengthBytes :: Block ty -> Size Word8-lengthBytes (Block ba) = Size (I# (sizeofByteArray# ba))+lengthBytes :: Block ty -> CountOf Word8+lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba)) {-# INLINE[1] lengthBytes #-}  -- | Create an empty block of memory@@ -92,13 +97,14 @@ -- use 'index' if unsure. unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty unsafeIndex (Block ba) n = primBaIndex ba n+{-# SPECIALIZE unsafeIndex :: Block Word8 -> Offset Word8 -> Word8 #-} {-# INLINE unsafeIndex #-}  -- | make a block from a list of elements. internalFromList :: PrimType ty => [ty] -> Block ty internalFromList l = runST $ do-    ma <- new (Size len)-    iter 0 l $ \i x -> unsafeWrite ma i x+    ma <- new (CountOf len)+    iter azero l $ \i x -> unsafeWrite ma i x     unsafeFreeze ma   where len = Data.List.length l         iter _  []     _ = return ()@@ -107,45 +113,76 @@ -- | transform a block to a list. internalToList :: forall ty . PrimType ty => Block ty -> [ty] internalToList blk@(Block ba)-    | len == 0  = []-    | otherwise = loop 0+    | len == azero = []+    | otherwise    = loop azero   where-    !len = lengthSize blk+    !len = length blk     loop !i | i .==# len = []             | otherwise  = primBaIndex ba i : loop (i+1) --- | Check if two vectors are identical+-- | Check if two blocks are identical equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool equal a b     | la /= lb  = False-    | otherwise = loop 0+    | otherwise = loop azero   where-    !la = lengthSize a-    !lb = lengthSize b-    loop n | n .==# la = True-           | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1)+    !la = lengthBytes a+    !lb = lengthBytes b+    lat = length a --- | Compare 2 vectors+    loop !n | n .==# lat = True+            | otherwise  = (unsafeIndex a n == unsafeIndex b n) && loop (n+o1)+    o1 = Offset (I# 1#)+{-# RULES "Block/Eq/Word8" [3]+   forall (a :: Block Word8) b . equal a b = equalMemcmp a b #-}+{-# INLINEABLE [2] equal #-}+-- {-# SPECIALIZE equal :: Block Word8 -> Block Word8 -> Bool #-}++equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool+equalMemcmp b1@(Block a) b2@(Block b)+    | la /= lb  = False+    | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 (csizeOfSize la)) == 0+  where+    la = lengthBytes b1+    lb = lengthBytes b2+{-# SPECIALIZE equalMemcmp :: Block Word8 -> Block Word8 -> Bool #-}++-- | Compare 2 blocks internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering-internalCompare a b = loop 0+internalCompare a b = loop azero   where-    !la = lengthSize a-    !lb = lengthSize b-    loop n-        | n .==# la = if la == lb then EQ else LT-        | n .==# lb = GT-        | otherwise =-            case unsafeIndex a n `compare` unsafeIndex b n of-                EQ -> loop (n+1)-                r  -> r+    !la = length a+    !lb = length b+    !end = sizeAsOffset (min la lb)+    loop !n+        | n == end  = la `compare` lb+        | v1 == v2  = loop (n + Offset (I# 1#))+        | otherwise = v1 `compare` v2+      where+        v1 = unsafeIndex a n+        v2 = unsafeIndex b n+{-# RULES "Block/Ord/Word8" [3] forall (a :: Block Word8) b . internalCompare a b = compareMemcmp a b #-}+{-# NOINLINE internalCompare #-} --- | Append 2 arrays together by creating a new bigger array+compareMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Ordering+compareMemcmp b1@(Block a) b2@(Block b) =+    case unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 sz) of+        0             -> la `compare` lb+        n | n > 0     -> GT+          | otherwise -> LT+  where+    la = lengthBytes b1+    lb = lengthBytes b2+    sz = csizeOfSize $ min la lb+{-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-}++-- | Append 2 blocks together by creating a new bigger block append :: Block ty -> Block ty -> Block ty append a b-    | la == 0 = b-    | lb == 0 = a+    | la == azero = b+    | lb == azero = a     | otherwise = runST $ do-        r  <- unsafeNew (la+lb)+        r  <- unsafeNew unpinned (la+lb)         unsafeCopyBytesRO r 0                 a 0 la         unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb         unsafeFreeze r@@ -160,7 +197,7 @@         (_,[])            -> empty         (_,[x])           -> x         (totalLen,chunks) -> runST $ do-            r <- unsafeNew totalLen+            r <- unsafeNew unpinned totalLen             doCopy r 0 chunks             unsafeFreeze r   where@@ -204,21 +241,28 @@ -- of the underlaying element 'ty' in the block. -- -- use 'new' if unsure-unsafeNew :: PrimMonad prim => Size Word8 -> prim (MutableBlock ty (PrimState prim))-unsafeNew (Size (I# bytes)) =-    primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }+unsafeNew :: PrimMonad prim+          => PinnedStatus+          -> CountOf Word8+          -> prim (MutableBlock ty (PrimState prim))+unsafeNew pinStatus (CountOf (I# bytes))+    | isPinned pinStatus = primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }+    | otherwise          = primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }  -- | Create a new mutable block of a specific N size of 'ty' elements-new :: forall prim ty . (PrimMonad prim, PrimType ty) => Size ty -> prim (MutableBlock ty (PrimState prim))-new n = unsafeNew (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)+new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))+new n = unsafeNew unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) +newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))+newPinned n = unsafeNew pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)+ -- | Copy a number of elements from an array to another array with offsets unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)                    => MutableBlock ty (PrimState prim) -- ^ destination mutable block                    -> Offset ty                        -- ^ offset at destination                    -> MutableBlock ty (PrimState prim) -- ^ source mutable block                    -> Offset ty                        -- ^ offset at source-                   -> Size ty                          -- ^ number of elements to copy+                   -> CountOf ty                          -- ^ number of elements to copy                    -> prim () unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n =     unsafeCopyBytes dstMb (offsetOfE sz destOffset)@@ -232,7 +276,7 @@                      -> Offset ty                        -- ^ offset at destination                      -> Block ty                         -- ^ source block                      -> Offset ty                        -- ^ offset at source-                     -> Size ty                          -- ^ number of elements to copy+                     -> CountOf ty                          -- ^ number of elements to copy                      -> prim () unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n =     unsafeCopyBytesRO dstMb (offsetOfE sz destOffset)@@ -247,9 +291,9 @@                 -> Offset Word8                     -- ^ offset at destination                 -> MutableBlock ty (PrimState prim) -- ^ source mutable block                 -> Offset Word8                     -- ^ offset at source-                -> Size Word8                       -- ^ number of elements to copy+                -> CountOf Word8                       -- ^ number of elements to copy                 -> prim ()-unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (Size (I# n)) =+unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (CountOf (I# n)) =     primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #) {-# INLINE unsafeCopyBytes #-} @@ -259,9 +303,9 @@                   -> Offset Word8                     -- ^ offset at destination                   -> Block ty                         -- ^ source block                   -> Offset Word8                     -- ^ offset at source-                  -> Size Word8                       -- ^ number of elements to copy+                  -> CountOf Word8                       -- ^ number of elements to copy                   -> prim ()-unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (Size (I# n)) =+unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (CountOf (I# n)) =     primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #) {-# INLINE unsafeCopyBytesRO #-} 

@@ -7,7 +7,7 @@ -- very similar to an unboxed array but with the key difference: -- -- * It doesn't have slicing capability (no cheap take or drop)--- * It consume less memory: 1 Offset, 1 Size, 1 Pinning status trimmed+-- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed -- * It's unpackable in any constructor -- * It uses unpinned memory by default --@@ -38,7 +38,9 @@     , MutableBlock(..)     , mutableLengthSize     , mutableLengthBytes+    , mutableGetAddr     , new+    , newPinned     , isPinned     , iterSet     , read@@ -68,15 +70,15 @@ -- | Return the length of a Mutable Block -- -- note: we don't allow resizing yet, so this can remain a pure function-mutableLengthSize :: forall ty st . PrimType ty => MutableBlock ty st -> Size ty+mutableLengthSize :: forall ty st . PrimType ty => MutableBlock ty st -> CountOf ty mutableLengthSize (MutableBlock mba) =-    let !(Size (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)+    let !(CountOf (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)         !elems              = quotInt# (sizeofMutableByteArray# mba) szBits-     in Size (I# elems)+     in CountOf (I# elems) {-# INLINE[1] mutableLengthSize #-} -mutableLengthBytes :: MutableBlock ty st -> Size Word8-mutableLengthBytes (MutableBlock mba) = Size (I# (sizeofMutableByteArray# mba))+mutableLengthBytes :: MutableBlock ty st -> CountOf Word8+mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba)) {-# INLINE[1] mutableLengthBytes #-}  -- | Return if a Mutable Block is pinned or not@@ -86,6 +88,13 @@     -- in 8.2, there's a primitive to know if an array in pinned     I# (sizeofMutableByteArray# mba) > 3000 +-- | Get the address of the context of the mutable block.+--+-- if the block is not pinned, this is a _dangerous_ operation+mutableGetAddr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Ptr ty)+mutableGetAddr (MutableBlock mba) = primitive $ \s1 ->+    case unsafeFreezeByteArray# mba s1 of+        (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)  -- | Set all mutable block element to a value iterSet :: (PrimType ty, PrimMonad prim)

@@ -28,7 +28,7 @@ -- * OOB_Index: reading an immutable vector -- * OOB_Read: reading a mutable vector -- * OOB_Write: write a mutable vector-data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_Index+data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_MemCopy | OOB_Index     deriving (Show,Eq,Typeable)  -- | Exception during an operation accessing the vector out of bound@@ -39,16 +39,16 @@  instance Exception OutOfBound -outOfBound :: OutOfBoundOperation -> Offset ty -> Size ty -> a-outOfBound oobop (Offset ofs) (Size sz) = throw (OutOfBound oobop ofs sz)+outOfBound :: OutOfBoundOperation -> Offset ty -> CountOf ty -> a+outOfBound oobop (Offset ofs) (CountOf sz) = throw (OutOfBound oobop ofs sz) {-# INLINE outOfBound #-} -primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> Size ty -> prim a-primOutOfBound oobop (Offset ofs) (Size sz) = primThrow (OutOfBound oobop ofs sz)+primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> CountOf ty -> prim a+primOutOfBound oobop (Offset ofs) (CountOf sz) = primThrow (OutOfBound oobop ofs sz) {-# INLINE primOutOfBound #-} -isOutOfBound :: Offset ty -> Size ty -> Bool-isOutOfBound (Offset ty) (Size sz) = ty < 0 || ty >= sz+isOutOfBound :: Offset ty -> CountOf ty -> Bool+isOutOfBound (Offset ty) (CountOf sz) = ty < 0 || ty >= sz {-# INLINE isOutOfBound #-}  newtype RecastSourceSize      = RecastSourceSize Int

@@ -42,7 +42,7 @@     , Prelude.Integer     , Foundation.Internal.Natural.Natural     , Foundation.Primitive.Types.OffsetSize.Offset-    , Foundation.Primitive.Types.OffsetSize.Size+    , Foundation.Primitive.Types.OffsetSize.CountOf     , Prelude.Char     , Foundation.Primitive.UTF8.Base.String     , Foundation.Array.Unboxed.UArray

@@ -162,6 +162,19 @@     integralDownsize      (I# i) = I32# (narrow32Int# i)     integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int64 Int8 where+    integralDownsize      i = integralDownsize (int64ToInt i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int64 Int16 where+    integralDownsize      i = integralDownsize (int64ToInt i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int64 Int32 where+    integralDownsize      i = integralDownsize (int64ToInt i)+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Int64 Int where+    integralDownsize      i = int64ToInt i+    integralDownsizeCheck = integralDownsizeBounded integralDownsize+ instance IntegralDownsize Word64 Word8 where     integralDownsize      (W64# i) = W8# (narrow8Word# (word64ToWord# i))     integralDownsizeCheck = integralDownsizeBounded integralDownsize@@ -255,6 +268,13 @@ intToInt64 (I# i) = I64# i #else intToInt64 (I# i) = I64# (intToInt64# i)+#endif++int64ToInt :: Int64 -> Int+#if WORD_SIZE_IN_BITS == 64+int64ToInt (I64# i) = I# i+#else+int64ToInt (I64# i) = I# (int64ToInt# i) #endif  wordToWord64 :: Word -> Word64

@@ -67,7 +67,7 @@ ----- -- Basic Foundation primitive types instance NormalForm (Offset a) where toNormalForm !_ = ()-instance NormalForm (Size a) where toNormalForm !_ = ()+instance NormalForm (CountOf a) where toNormalForm !_ = ()  ----- -- composed type

@@ -26,5 +26,5 @@ unsafeUArrayUnpinnedMaxSize :: Size8 unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do     maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"-    return $ maybe (Size 1024) Size maxSize+    return $ maybe (CountOf 1024) CountOf maxSize {-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}

@@ -11,6 +11,7 @@ {-# LANGUAGE CPP #-} module Foundation.Primitive.Types     ( PrimType(..)+    , PrimMemoryComparable     , primBaIndex     , primMbaRead     , primMbaWrite@@ -23,6 +24,7 @@     , offsetAsSize     , sizeAsOffset     , sizeInBytes+    , offsetInBytes     , primWordGetByteAndShift     , primWord64GetByteAndShift     , primWord64GetHiLo@@ -52,7 +54,7 @@ divBytes ofs = \x -> x `Prelude.quot` (getSize Proxy ofs)   where     getSize :: PrimType ty => Proxy ty -> Offset ty -> Int-    getSize p _ = let (Size sz) = primSizeInBytes p in sz+    getSize p _ = let (CountOf sz) = primSizeInBytes p in sz  baLength :: PrimType ty => Offset ty -> ByteArray# -> Int baLength ofs ba = divBytes ofs (I# (sizeofByteArray# ba))@@ -198,13 +200,13 @@                   -> ty                   -> prim () -sizeInt, sizeWord :: Size Word8+sizeInt, sizeWord :: CountOf Word8 #if WORD_SIZE_IN_BITS == 64-sizeInt = Size 8-sizeWord = Size 8+sizeInt = CountOf 8+sizeWord = CountOf 8 #else-sizeInt = Size 4-sizeWord = Size 4+sizeInt = CountOf 4+sizeWord = CountOf 4 #endif  {-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-}@@ -242,7 +244,7 @@     {-# INLINE primAddrWrite #-}  instance PrimType Word8 where-    primSizeInBytes _ = Size 1+    primSizeInBytes _ = CountOf 1     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n)     {-# INLINE primBaUIndex #-}@@ -258,7 +260,7 @@     {-# INLINE primAddrWrite #-}  instance PrimType Word16 where-    primSizeInBytes _ = Size 2+    primSizeInBytes _ = CountOf 2     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n)     {-# INLINE primBaUIndex #-}@@ -273,7 +275,7 @@     primAddrWrite addr (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Word32 where-    primSizeInBytes _ = Size 4+    primSizeInBytes _ = CountOf 4     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n)     {-# INLINE primBaUIndex #-}@@ -288,7 +290,7 @@     primAddrWrite addr (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Word64 where-    primSizeInBytes _ = Size 8+    primSizeInBytes _ = CountOf 8     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n)     {-# INLINE primBaUIndex #-}@@ -303,7 +305,7 @@     primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Int8 where-    primSizeInBytes _ = Size 1+    primSizeInBytes _ = CountOf 1     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n)     {-# INLINE primBaUIndex #-}@@ -318,7 +320,7 @@     primAddrWrite addr (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Int16 where-    primSizeInBytes _ = Size 2+    primSizeInBytes _ = CountOf 2     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n)     {-# INLINE primBaUIndex #-}@@ -333,7 +335,7 @@     primAddrWrite addr (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Int32 where-    primSizeInBytes _ = Size 4+    primSizeInBytes _ = CountOf 4     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n)     {-# INLINE primBaUIndex #-}@@ -348,7 +350,7 @@     primAddrWrite addr (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32OffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Int64 where-    primSizeInBytes _ = Size 8+    primSizeInBytes _ = CountOf 8     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n)     {-# INLINE primBaUIndex #-}@@ -364,7 +366,7 @@     {-# INLINE primAddrWrite #-}  instance PrimType Float where-    primSizeInBytes _ = Size 4+    primSizeInBytes _ = CountOf 4     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n)     {-# INLINE primBaUIndex #-}@@ -379,7 +381,7 @@     primAddrWrite addr (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatOffAddr# addr n w s1, () #)     {-# INLINE primAddrWrite #-} instance PrimType Double where-    primSizeInBytes _ = Size 8+    primSizeInBytes _ = CountOf 8     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n)     {-# INLINE primBaUIndex #-}@@ -395,7 +397,7 @@     {-# INLINE primAddrWrite #-}  instance PrimType Char where-    primSizeInBytes _ = Size 4+    primSizeInBytes _ = CountOf 4     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n)     {-# INLINE primBaUIndex #-}@@ -411,7 +413,7 @@     {-# INLINE primAddrWrite #-}  instance PrimType CChar where-    primSizeInBytes _ = Size 1+    primSizeInBytes _ = CountOf 1     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n))     {-# INLINE primBaUIndex #-}@@ -426,7 +428,7 @@     primAddrWrite addr (Offset n) (CChar int8) = primAddrWrite addr (Offset n) int8     {-# INLINE primAddrWrite #-} instance PrimType CUChar where-    primSizeInBytes _ = Size 1+    primSizeInBytes _ = CountOf 1     {-# INLINE primSizeInBytes #-}     primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8))     {-# INLINE primBaUIndex #-}@@ -472,33 +474,68 @@     primAddrWrite addr (Offset a) (BE w) = primAddrWrite addr (Offset a) w     {-# INLINE primAddrWrite #-} +-- | A constraint class for serializable type that have an unique+-- memory compare representation+--+-- e.g. Float and Double have -0.0 and 0.0 which are Eq individual,+-- yet have a different memory representation which doesn't allow+-- for memcmp operation+class PrimMemoryComparable ty where --- | Cast a Size linked to type A (Size A) to a Size linked to type B (Size B)-sizeRecast :: (PrimType a, PrimType b) => Size a -> Size b-sizeRecast = doRecast Proxy Proxy-  where doRecast :: (PrimType a, PrimType b) => Proxy a -> Proxy b -> Size a -> Size b-        doRecast pa pb sz =-            let szA          = primSizeInBytes pa-                (Size szB)   = primSizeInBytes pb-                (Size bytes) = sizeOfE szA sz-             in Size (bytes `Prelude.quot` szB)+instance PrimMemoryComparable Int where+instance PrimMemoryComparable Word where+instance PrimMemoryComparable Word8 where+instance PrimMemoryComparable Word16 where+instance PrimMemoryComparable Word32 where+instance PrimMemoryComparable Word64 where+instance PrimMemoryComparable Int8 where+instance PrimMemoryComparable Int16 where+instance PrimMemoryComparable Int32 where+instance PrimMemoryComparable Int64 where+instance PrimMemoryComparable Char where+instance PrimMemoryComparable CChar where+instance PrimMemoryComparable CUChar where+instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where+instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where -sizeInBytes :: forall a . PrimType a => Size a -> Size Word8+-- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B)+sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b+sizeRecast sz = CountOf (bytes `Prelude.quot` szB)+  where !szA          = primSizeInBytes (Proxy :: Proxy a)+        !(CountOf szB)   = primSizeInBytes (Proxy :: Proxy b)+        !(CountOf bytes) = sizeOfE szA sz+{-# INLINE [1] sizeRecast #-}+{-# RULES "sizeRecast from Word8" [2] forall a . sizeRecast a = sizeRecastBytes a #-}++sizeRecastBytes :: forall b . PrimType b => CountOf Word8 -> CountOf b+sizeRecastBytes (CountOf w) = CountOf (w `Prelude.quot` szB)+  where !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b)+{-# INLINE [1] sizeRecastBytes #-}++sizeInBytes :: forall a . PrimType a => CountOf a -> CountOf Word8 sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz -primOffsetRecast :: (PrimType a, PrimType b) => Offset a -> Offset b-primOffsetRecast = doRecast Proxy Proxy-  where doRecast :: (PrimType a, PrimType b) => Proxy a -> Proxy b -> Offset a -> Offset b-        doRecast pa pb ofs =-            let szA            = primSizeInBytes pa-                (Size szB)     = primSizeInBytes pb-                (Offset bytes) = offsetOfE szA ofs-             in Offset (bytes `Prelude.quot` szB)+offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8+offsetInBytes sz = offsetOfE (primSizeInBytes (Proxy :: Proxy a)) sz -primOffsetOfE :: PrimType a => Offset a -> Offset8-primOffsetOfE = getOffset Proxy-  where getOffset :: PrimType a => Proxy a -> Offset a -> Offset8-        getOffset proxy = offsetOfE (primSizeInBytes proxy)+primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b+primOffsetRecast !ofs =+    let !(Offset bytes) = offsetOfE szA ofs+     in Offset (bytes `Prelude.quot` szB)+  where+    !szA        = primSizeInBytes (Proxy :: Proxy a)+    !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b)+{-# INLINE [1] primOffsetRecast #-}+{-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-}++primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b+primOffsetRecastBytes !(Offset o) = Offset (szA `Prelude.quot` o)+  where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b)+{-# INLINE [1] primOffsetRecastBytes #-}++primOffsetOfE :: forall a . PrimType a => Offset a -> Offset Word8+primOffsetOfE = offsetInBytes+{-# DEPRECATED primOffsetOfE "use offsetInBytes" #-}  primWordGetByteAndShift :: Word# -> (# Word#, Word# #) primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #)

@@ -6,7 +6,9 @@ -- Portability : portable -- {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE CPP                        #-} module Foundation.Primitive.Types.OffsetSize     ( FileSize(..)     , Offset(..)@@ -19,16 +21,27 @@     , sizeCast     , sizeLastOffset     , sizeAsOffset+    , sizeSub     , offsetAsSize     , (+.)     , (.==#)-    , Size(..)+    , CountOf(..)     , Size8     , sizeOfE+    , csizeOfOffset+    , csizeOfSize+    , sizeOfCSSize+    , sizeOfCSize     ) where +#include "MachDeps.h"+ import GHC.Types import GHC.Word+import GHC.Int+import GHC.Prim+import Foreign.C.Types+import System.Posix.Types (CSsize (..)) import Foundation.Internal.Base import Foundation.Internal.Proxy import Foundation.Numerical.Primitives@@ -36,7 +49,13 @@ import Foundation.Numerical.Additive import Foundation.Numerical.Subtractive import Foundation.Numerical.Multiplicative+import Foundation.Primitive.IntegralConv+import Data.List (foldl') +#if WORD_SIZE_IN_BITS < 64+import GHC.IntWord64+#endif+ -- $setup -- >>> import Foundation.Array.Unboxed @@ -53,44 +72,45 @@ -- considering that GHC/Haskell are mostly using this for offset. -- Trying to bring some sanity by a lightweight wrapping. newtype Offset ty = Offset Int-    deriving (Show,Eq,Ord,Enum)+    deriving (Show,Eq,Ord,Enum,Additive,Typeable)  instance Integral (Offset ty) where     fromInteger n-        | n < 0     = error "Size: fromInteger: negative"+        | n < 0     = error "CountOf: fromInteger: negative"         | otherwise = Offset . fromInteger $ n instance IsIntegral (Offset ty) where     toInteger (Offset i) = toInteger i instance IsNatural (Offset ty) where     toNatural (Offset i) = toNatural (intToWord i)--instance Additive (Offset ty) where-    azero = Offset 0-    (+) (Offset a) (Offset b) = Offset (a+b)- instance Subtractive (Offset ty) where-    type Difference (Offset ty) = Size ty-    (Offset a) - (Offset b) = Size (a-b)+    type Difference (Offset ty) = CountOf ty+    (Offset a) - (Offset b) = CountOf (a-b)+instance IntegralCast Int (Offset ty) where+    integralCast i = Offset i+instance IntegralCast Word (Offset ty) where+    integralCast (W# w) = Offset (I# (word2Int# w)) + (+.) :: Offset ty -> Int -> Offset ty (+.) (Offset a) b = Offset (a + b)+{-# INLINE (+.) #-}  -- . is offset (as a pointer from a beginning), and # is the size (amount of data)-(.==#) :: Offset ty -> Size ty -> Bool-(.==#) (Offset ofs) (Size sz) = ofs == sz+(.==#) :: Offset ty -> CountOf ty -> Bool+(.==#) (Offset ofs) (CountOf sz) = ofs == sz {-# INLINE (.==#) #-}  offsetOfE :: Size8 -> Offset ty -> Offset8-offsetOfE (Size sz) (Offset ty) = Offset (ty * sz)+offsetOfE (CountOf sz) (Offset ty) = Offset (ty * sz) -offsetPlusE :: Offset ty -> Size ty -> Offset ty-offsetPlusE (Offset ofs) (Size sz) = Offset (ofs + sz)+offsetPlusE :: Offset ty -> CountOf ty -> Offset ty+offsetPlusE (Offset ofs) (CountOf sz) = Offset (ofs + sz) -offsetMinusE :: Offset ty -> Size ty -> Offset ty-offsetMinusE (Offset ofs) (Size sz) = Offset (ofs - sz)+offsetMinusE :: Offset ty -> CountOf ty -> Offset ty+offsetMinusE (Offset ofs) (CountOf sz) = Offset (ofs - sz)  offsetRecast :: Size8 -> Size8 -> Offset ty -> Offset ty2-offsetRecast szTy (Size szTy2) ofs =+offsetRecast szTy (CountOf szTy2) ofs =     let (Offset bytes) = offsetOfE szTy ofs      in Offset (bytes `div` szTy2) @@ -98,56 +118,110 @@ offsetCast _ (Offset o) = Offset o {-# INLINE offsetCast #-} -sizeCast :: Proxy (a -> b) -> Size a -> Size b-sizeCast _ (Size sz) = Size sz+sizeCast :: Proxy (a -> b) -> CountOf a -> CountOf b+sizeCast _ (CountOf sz) = CountOf sz {-# INLINE sizeCast #-} +-- | subtract 2 CountOf values of the same type.+--+-- m need to be greater than n, otherwise negative count error ensue+-- use the safer (-) version if unsure.+sizeSub :: CountOf a -> CountOf a -> CountOf a+sizeSub (CountOf m) (CountOf n)+    | m > n     = CountOf diff+    | otherwise = error "sizeSub negative size"+  where+    diff = m - n+ -- TODO add a callstack, or a construction to prevent size == 0 error-sizeLastOffset :: Size a -> Offset a-sizeLastOffset (Size s)+sizeLastOffset :: CountOf a -> Offset a+sizeLastOffset (CountOf s)     | s > 0     = Offset (pred s)     | otherwise = error "last offset on size 0" -sizeAsOffset :: Size a -> Offset a-sizeAsOffset (Size a) = Offset a+sizeAsOffset :: CountOf a -> Offset a+sizeAsOffset (CountOf a) = Offset a {-# INLINE sizeAsOffset #-} -offsetAsSize :: Offset a -> Size a-offsetAsSize (Offset a) = Size a+offsetAsSize :: Offset a -> CountOf a+offsetAsSize (Offset a) = CountOf a {-# INLINE offsetAsSize #-}  --- | Size of a data structure in bytes.-type Size8 = Size Word8--instance Integral (Size ty) where-    fromInteger n-        | n < 0     = error "Size: fromInteger: negative"-        | otherwise = Size . fromInteger $ n-instance IsIntegral (Size ty) where-    toInteger (Size i) = toInteger i-instance IsNatural (Size ty) where-    toNatural (Size i) = toNatural (intToWord i)--instance Additive (Size ty) where-    azero = Size 0-    (+) (Size a) (Size b) = Size (a+b)--instance Subtractive (Size ty) where-    type Difference (Size ty) = Size ty-    (Size a) - (Size b) = Size (a-b)+-- | CountOf of a data structure in bytes.+type Size8 = CountOf Word8 --- | Size of a data structure.+-- | CountOf of a data structure. -- -- More specifically, it represents the number of elements of type `ty` that fit -- into the data structure. ----- >>> lengthSize (fromList ['a', 'b', 'c', '🌟']) :: Size Char--- Size 4+-- >>> length (fromList ['a', 'b', 'c', '🌟']) :: CountOf Char+-- CountOf 4 -- -- Same caveats as 'Offset' apply here.-newtype Size ty = Size Int-    deriving (Show,Eq,Ord,Enum)+newtype CountOf ty = CountOf Int+    deriving (Show,Eq,Ord,Enum,Typeable) -sizeOfE :: Size8 -> Size ty -> Size8-sizeOfE (Size sz) (Size ty) = Size (ty * sz)+instance Integral (CountOf ty) where+    fromInteger n+        | n < 0     = error "CountOf: fromInteger: negative"+        | otherwise = CountOf . fromInteger $ n+instance IsIntegral (CountOf ty) where+    toInteger (CountOf i) = toInteger i+instance IsNatural (CountOf ty) where+    toNatural (CountOf i) = toNatural (intToWord i)++instance Additive (CountOf ty) where+    azero = CountOf 0+    (+) (CountOf a) (CountOf b) = CountOf (a+b)++instance Subtractive (CountOf ty) where+    type Difference (CountOf ty) = CountOf ty+    (CountOf a) - (CountOf b) = CountOf (a-b)++instance Monoid (CountOf ty) where+    mempty = azero+    mappend = (+)+    mconcat = foldl' (+) 0++instance IntegralCast Int (CountOf ty) where+    integralCast i = CountOf i+instance IntegralCast Word (CountOf ty) where+    integralCast (W# w) = CountOf (I# (word2Int# w))++sizeOfE :: Size8 -> CountOf ty -> Size8+sizeOfE (CountOf sz) (CountOf ty) = CountOf (ty * sz)++-- when #if WORD_SIZE_IN_BITS < 64 the 2 following are wrong+-- instead of using FromIntegral and being silently wrong+-- explicit pattern match to sort it out.++csizeOfSize :: Size8 -> CSize+#if WORD_SIZE_IN_BITS < 64+csizeOfSize (CountOf (I# sz)) = CSize (W32# (int2Word# sz))+#else+csizeOfSize (CountOf (I# sz)) = CSize (W64# (int2Word# sz))+#endif++csizeOfOffset :: Offset8 -> CSize+#if WORD_SIZE_IN_BITS < 64+csizeOfOffset (Offset (I# sz)) = CSize (W32# (int2Word# sz))+#else+csizeOfOffset (Offset (I# sz)) = CSize (W64# (int2Word# sz))+#endif++sizeOfCSSize :: CSsize -> Size8+sizeOfCSSize (CSsize (-1))      = error "invalid size: CSSize is -1"+#if WORD_SIZE_IN_BITS < 64+sizeOfCSSize (CSsize (I32# sz)) = CountOf (I# sz)+#else+sizeOfCSSize (CSsize (I64# sz)) = CountOf (I# sz)+#endif++sizeOfCSize :: CSize -> Size8+#if WORD_SIZE_IN_BITS < 64+sizeOfCSize (CSize (W32# sz)) = CountOf (I# (word2Int# sz))+#else+sizeOfCSize (CSize (W64# sz)) = CountOf (I# (word2Int# sz))+#endif

@@ -0,0 +1,40 @@+{-# LANGUAGE MagicHash #-}+module Foundation.Primitive.Types.Ptr+    ( Addr(..)+    , addrPlus+    , addrPlusSz+    , addrPlusCSz+    , Ptr(..)+    , ptrPlus+    , ptrPlusSz+    , ptrPlusCSz+    , castPtr+    ) where++import           Foundation.Internal.Base+import           Foundation.Primitive.Types.OffsetSize+import           GHC.Ptr+import           GHC.Prim+import           GHC.Types+import           Foreign.C.Types++data Addr = Addr Addr#+    deriving (Eq,Ord)++addrPlus :: Addr -> Offset Word8 -> Addr+addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i)++addrPlusSz :: Addr -> CountOf Word8 -> Addr+addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i)++addrPlusCSz :: Addr -> CSize -> Addr+addrPlusCSz addr = addrPlusSz addr . sizeOfCSize++ptrPlus :: Ptr a -> Offset Word8 -> Ptr a+ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i)++ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a+ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i)++ptrPlusCSz :: Ptr a -> CSize -> Ptr a+ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize

@@ -76,8 +76,8 @@ -- | size in bytes. -- -- this size is available in o(1)-size :: String -> Size Word8-size (String ba) = Vec.lengthSize ba+size :: String -> CountOf Word8+size (String ba) = Vec.length ba  -- | Convert a String to a list of characters --

@@ -104,24 +104,24 @@  -- given the encoding of UTF8 Char, get the number of bytes of this sequence numBytes :: UTF8Char -> Size8-numBytes UTF8_1{} = Size 1-numBytes UTF8_2{} = Size 2-numBytes UTF8_3{} = Size 3-numBytes UTF8_4{} = Size 4+numBytes UTF8_1{} = CountOf 1+numBytes UTF8_2{} = CountOf 2+numBytes UTF8_3{} = CountOf 3+numBytes UTF8_4{} = CountOf 4  -- given the leading byte of a utf8 sequence, get the number of bytes of this sequence-skipNextHeaderValue :: Word8 -> Size Word8+skipNextHeaderValue :: Word8 -> CountOf Word8 skipNextHeaderValue !x-    | x < 0xC0  = Size 1 -- 0b11000000-    | x < 0xE0  = Size 2 -- 0b11100000-    | x < 0xF0  = Size 3 -- 0b11110000-    | otherwise = Size 4+    | x < 0xC0  = CountOf 1 -- 0b11000000+    | x < 0xE0  = CountOf 2 -- 0b11100000+    | x < 0xF0  = CountOf 3 -- 0b11110000+    | otherwise = CountOf 4 {-# INLINE skipNextHeaderValue #-}  charToBytes :: Int -> Size8 charToBytes c-    | c < 0x80     = Size 1-    | c < 0x800    = Size 2-    | c < 0x10000  = Size 3-    | c < 0x110000 = Size 4+    | c < 0x80     = CountOf 1+    | c < 0x800    = CountOf 2+    | c < 0x10000  = CountOf 3+    | c < 0x110000 = CountOf 4     | otherwise    = error ("invalid code point: " `mappend` show c)

@@ -40,7 +40,7 @@  -- | A monad constraint that allows to generate random bytes class (Functor m, Applicative m, Monad m) => MonadRandom m where-    getRandomBytes :: Size Word8 -> m (UArray Word8)+    getRandomBytes :: CountOf Word8 -> m (UArray Word8)  instance MonadRandom IO where     getRandomBytes = getEntropy@@ -57,7 +57,7 @@     randomNewFrom :: UArray Word8 -> Maybe gen      -- | Generate N bytes of randomness from a DRG-    randomGenerate :: Size Word8 -> gen -> (UArray Word8, gen)+    randomGenerate :: CountOf Word8 -> gen -> (UArray Word8, gen)  -- | A simple Monad class very similar to a State Monad -- with the state being a RandomGenerator.@@ -115,11 +115,11 @@         | otherwise         = Nothing     randomGenerate = rngv1Generate -rngv1KeySize :: Size Word8+rngv1KeySize :: CountOf Word8 rngv1KeySize = 32 -rngv1Generate :: Size Word8 -> RNGv1 -> (UArray Word8, RNGv1)-rngv1Generate n@(Size x) (RNGv1 key) = runST $ do+rngv1Generate :: CountOf Word8 -> RNGv1 -> (UArray Word8, RNGv1)+rngv1Generate n@(CountOf x) (RNGv1 key) = runST $ do     dst    <- A.newPinned n     newKey <- A.newPinned rngv1KeySize     A.withMutablePtr dst        $ \dstP    ->

@@ -127,13 +127,10 @@ sToList :: AsciiString -> [CUChar] sToList s = loop azero   where-    nbBytes :: Size CUChar-    !nbBytes = size s-    !end = azero `offsetPlusE` nbBytes+    !len = length s     loop idx-        | idx == end = []-        | otherwise  =-            let (# c , idx' #) = next s idx in c : loop idx'+        | idx .==# len = []+        | otherwise    = let (# c , idx' #) = next s idx in c : loop idx'  sFromList :: [CUChar] -> AsciiString sFromList = AsciiString . fromList@@ -146,29 +143,29 @@ -- | Create a string composed of a number @n of Chars (Unicode code points). -- -- if the input @s contains less characters than required, then-take :: Int -> AsciiString -> AsciiString+take :: CountOf CUChar -> AsciiString -> AsciiString take n s = fst $ splitAt n s -- TODO specialize {-# INLINE take #-}  -- | Create a string with the remaining Chars after dropping @n Chars from the beginning-drop :: Int -> AsciiString -> AsciiString+drop :: CountOf CUChar -> AsciiString -> AsciiString drop n = AsciiString . Vec.drop n . toBytes {-# INLINE drop #-} -splitAt :: Int -> AsciiString -> (AsciiString, AsciiString)+splitAt :: CountOf CUChar -> AsciiString -> (AsciiString, AsciiString) splitAt n = bimap AsciiString AsciiString . Vec.splitAt n . toBytes {-# INLINE splitAt #-}  -- rev{Take,Drop,SplitAt} TODO optimise: -- we can process the string from the end using a skipPrev instead of getting the length -revTake :: Int -> AsciiString -> AsciiString+revTake :: CountOf CUChar -> AsciiString -> AsciiString revTake nbElems v = drop (length v - nbElems) v -revDrop :: Int -> AsciiString -> AsciiString+revDrop :: CountOf CUChar -> AsciiString -> AsciiString revDrop nbElems v = take (length v - nbElems) v -revSplitAt :: Int -> AsciiString -> (AsciiString, AsciiString)+revSplitAt :: CountOf CUChar -> AsciiString -> (AsciiString, AsciiString) revSplitAt n v = (drop idx v, take idx v)   where idx = length v - n @@ -202,15 +199,11 @@ span :: (CUChar -> Bool) -> AsciiString -> (AsciiString, AsciiString) span predicate = break (not . predicate) --- | size in bytes-size :: AsciiString -> Size CUChar-size = Size . C.length . toBytes--length :: AsciiString -> Int-length s = let (Size l) = size s in l+length :: AsciiString -> CountOf CUChar+length (AsciiString ba) = C.length ba -replicate :: Int -> CUChar -> AsciiString-replicate n c = AsciiString $ Vec.create (Size n) (const c)+replicate :: CountOf CUChar -> CUChar -> AsciiString+replicate n c = AsciiString $ Vec.create n (const c)  -- | Copy the AsciiString copy :: AsciiString -> AsciiString@@ -218,17 +211,17 @@  -- | Allocate a MutableAsciiString of a specific size in bytes. new :: PrimMonad prim-    => Size CUChar -- ^ in number of bytes, not of elements.+    => CountOf CUChar -- ^ in number of bytes, not of elements.     -> prim (MutableAsciiString (PrimState prim)) new n = MutableAsciiString `fmap` MVec.new n -create :: PrimMonad prim => Int -> (MutableAsciiString (PrimState prim) -> prim Int) -> prim AsciiString+create :: PrimMonad prim => CountOf CUChar -> (MutableAsciiString (PrimState prim) -> prim (Offset CUChar)) -> prim AsciiString create sz f = do-    ms     <- new (Size sz)+    ms     <- new sz     filled <- f ms-    if filled == sz+    if filled .==# sz         then freeze ms-        else C.take filled `fmap` freeze ms+        else C.take (offsetAsSize filled) `fmap` freeze ms  cucharMap :: (CUChar -> CUChar) -> AsciiString -> AsciiString cucharMap f = AsciiString . Vec.map f . toBytes

@@ -94,10 +94,10 @@     | Vec.null bytes = return mempty     | otherwise      = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t)   where-    lastUnit = Offset $ Vec.length bytes+    lastUnit = Vec.length bytes      loop off getter-      | off >= lastUnit = return ()+      | off .==# lastUnit = return ()       | otherwise = case encodingNext inputEncodingTy getter off of           Left err -> throw err           Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter

@@ -36,8 +36,8 @@ accessBytes :: Offset Word8 -> (Offset Word8 -> Word8) -> ([Word8], Offset Word8) accessBytes offset getAtIdx = (loop offset, pastEnd)   where-    nbytes :: Size Word8-    nbytes = Size $ getNbBytes $ getAtIdx offset+    nbytes :: CountOf Word8+    nbytes = CountOf $ getNbBytes $ getAtIdx offset     pastEnd :: Offset Word8     pastEnd = 1 + (offset `offsetPlusE` nbytes)     loop :: Offset Word8 -> [Word8]@@ -46,7 +46,7 @@         | otherwise      = getAtIdx off : loop (off + 1)  buildByteArray :: Addr# -> ST st (UArray Word8)-buildByteArray addr = Vec.UVecAddr (Offset 0) (Size 100000) `fmap`+buildByteArray addr = Vec.UVecAddr (Offset 0) (CountOf 100000) `fmap`     toFinalPtr (Ptr addr) (\_ -> return ())  -- | assuming the given ByteArray is a valid modified UTF-8 sequence of bytes

@@ -52,6 +52,7 @@     , span     , break     , breakElem+    , dropWhile     , singleton     , charMap     , snoc@@ -73,6 +74,9 @@     , readFloatingExact     , upper     , lower+    , isPrefixOf+    , isSuffixOf+    , isInfixOf     -- * Legacy utility     , lines     , words@@ -140,7 +144,7 @@ -- On Failure the position along with the failure reason validate :: UArray Word8          -> Offset8-         -> Size Word8+         -> CountOf Word8          -> (Offset8, Maybe ValidationFailure) validate ba ofsStart sz = runST (Vec.unsafeIndexer ba go)   where@@ -183,14 +187,14 @@                 _ -> error "internal error"           where             !h = getIdx pos-            !nbContsE@(Size nbConts) = Size $ getNbBytes h+            !nbContsE@(CountOf nbConts) = CountOf $ getNbBytes h     {-# INLINE go #-}  -- | Similar to 'validate' but works on a 'MutableByteArray' mutableValidate :: PrimMonad prim                 => MutableByteArray (PrimState prim)                 -> Offset Word8-                -> Size Word8+                -> CountOf Word8                 -> prim (Offset Word8, Maybe ValidationFailure) mutableValidate mba ofsStart sz = do     loop ofsStart@@ -324,7 +328,7 @@     Vec.unsafeWrite mba (i+3) x4 {-# INLINE writeUTF8Char #-} -unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> Size Word8 -> prim String+unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> CountOf Word8 -> prim String unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s {-# INLINE unsafeFreezeShrink #-} @@ -335,75 +339,89 @@ null :: String -> Bool null (String ba) = C.length ba == 0 +-- we don't know in constant time the count of character in string,+-- however if we estimate bounds of what N characters would+-- take in space (between N and N*4). If the count is thus bigger than+-- the number of bytes, then we know for sure that it's going to+-- be out of bounds+countCharMoreThanBytes :: CountOf Char -> UArray Word8 -> Bool+countCharMoreThanBytes (CountOf chars) ba = chars >= bytes+  where (CountOf bytes) = C.length ba+ -- | Create a string composed of a number @n of Chars (Unicode code points). -- -- if the input @s contains less characters than required, then the input string is returned.-take :: Int -> String -> String+take :: CountOf Char -> String -> String take n s@(String ba)-    | n <= 0           = mempty-    | n >= C.length ba = s-    | otherwise        = let (Offset o) = indexN (Offset n) s in String $ Vec.take o ba+    | n <= 0                      = mempty+    | countCharMoreThanBytes n ba = s+    | otherwise                   = String $ Vec.unsafeTake (offsetAsSize $ indexN n s) ba  -- | Create a string with the remaining Chars after dropping @n Chars from the beginning-drop :: Int -> String -> String+drop :: CountOf Char -> String -> String drop n s@(String ba)-    | n <= 0           = s-    | n >= C.length ba = mempty-    | otherwise        = let (Offset o) = indexN (Offset n) s in String $ Vec.drop o ba+    | n <= 0                      = s+    | countCharMoreThanBytes n ba = mempty+    | otherwise                   = String $ Vec.drop (offsetAsSize $ indexN n s) ba  -- | Split a string at the Offset specified (in Char) returning both -- the leading part and the remaining part.-splitAt :: Int -> String -> (String, String)-splitAt nI s@(String ba)-    | nI <= 0           = (mempty, s)-    | nI >= C.length ba = (s, mempty)-    | otherwise =-        let (Offset k) = indexN (Offset nI) s-            (v1,v2)    = C.splitAt k ba+splitAt :: CountOf Char -> String -> (String, String)+splitAt n s@(String ba)+    | n <= 0                      = (mempty, s)+    | countCharMoreThanBytes n ba = (s, mempty)+    | otherwise                   =+        let (v1,v2) = C.splitAt (offsetAsSize $ indexN n s) ba          in (String v1, String v2)  -- | Return the offset (in bytes) of the N'th sequence in an UTF8 String-indexN :: Offset Char -> String -> Offset Word8+indexN :: CountOf Char -> String -> Offset Word8 indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba   where     goVec :: ByteArray# -> Offset Word8 -> Offset Word8     goVec !ma !start = loop start 0       where-        !len = start `offsetPlusE` Vec.lengthSize ba+        !len = start `offsetPlusE` Vec.length ba         loop :: Offset Word8 -> Offset Char -> Offset Word8         loop !idx !i-            | idx >= len || i >= n = sizeAsOffset (idx - start)-            | otherwise            = loop (idx `offsetPlusE` d) (i + Offset 1)+            | idx >= len || i .==# n = sizeAsOffset (idx - start)+            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)           where d = skipNextHeaderValue (primBaIndex ma idx)     {-# INLINE goVec #-}      goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8)     goAddr !(Ptr ptr) !start = return $ loop start (Offset 0)       where-        !len = start `offsetPlusE` Vec.lengthSize ba+        !len = start `offsetPlusE` Vec.length ba         loop :: Offset Word8 -> Offset Char -> Offset Word8         loop !idx !i-            | idx >= len || i >= n = sizeAsOffset (idx - start)-            | otherwise            = loop (idx `offsetPlusE` d) (i + Offset 1)+            | idx >= len || i .==# n = sizeAsOffset (idx - start)+            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)           where d = skipNextHeaderValue (primAddrIndex ptr idx)     {-# INLINE goAddr #-} {-# INLINE indexN #-} +-- inverse a CountOf that is specified from the end (e.g. take n Chars from the end)+-- -- rev{Take,Drop,SplitAt} TODO optimise: -- we can process the string from the end using a skipPrev instead of getting the length+countFromStart :: String -> CountOf Char -> CountOf Char+countFromStart s sz@(CountOf sz')+    | sz >= len = CountOf 0+    | otherwise = CountOf (len' - sz')+  where len@(CountOf len') = length s  -- | Similar to 'take' but from the end-revTake :: Int -> String -> String-revTake nbElems v = drop (length v - nbElems) v+revTake :: CountOf Char -> String -> String+revTake n v = drop (countFromStart v n) v  -- | Similar to 'drop' but from the end-revDrop :: Int -> String -> String-revDrop nbElems v = take (length v - nbElems) v+revDrop :: CountOf Char -> String -> String+revDrop n v = take (countFromStart v n) v  -- | Similar to 'splitAt' but from the end-revSplitAt :: Int -> String -> (String, String)-revSplitAt n v = (drop idx v, take idx v)-  where idx = length v - n+revSplitAt :: CountOf Char -> String -> (String, String)+revSplitAt n v = (drop idx v, take idx v) where idx = countFromStart v n  -- | Split on the input string using the predicate as separator --@@ -417,7 +435,7 @@ -- splitOn :: (Char -> Bool) -> String -> [String] splitOn predicate s-    | sz == Size 0 = [mempty]+    | sz == CountOf 0 = [mempty]     | otherwise    = loop azero azero   where     !sz = size s@@ -442,8 +460,8 @@ -- This is unsafe considering that one can split in the middle of a -- UTF8 sequence, so use with care. splitIndex :: Offset8 -> String -> (String, String)-splitIndex (Offset idx) (String ba) = (String v1, String v2)-  where (v1,v2) = C.splitAt idx ba+splitIndex idx (String ba) = (String v1, String v2)+  where (v1,v2) = C.splitAt (offsetAsSize idx) ba  -- | Break a string into 2 strings at the location where the predicate return True break :: (Char -> Bool) -> String -> (String, String)@@ -501,6 +519,10 @@ span :: (Char -> Bool) -> String -> (String, String) span predicate s = break (not . predicate) s +-- | Drop character from the beginning while the predicate is true+dropWhile :: (Char -> Bool) -> String -> String+dropWhile predicate = snd . break (not . predicate)+ -- | Return whereas the string contains a specific character or not elem :: Char -> String -> Bool elem !el s@(String ba) =@@ -533,7 +555,7 @@     | otherwise   = runST $ unsafeCopyFrom src dstBytes (go sep)   where     !srcBytes = size src-    !srcLen   = lengthSize src+    !srcLen   = length src     dstBytes = (srcBytes :: Size8)              + ((srcLen - 1) `scale` charToBytes (fromEnum sep)) @@ -562,46 +584,41 @@ unsafeCopyFrom src dstBytes f = new dstBytes >>= fill (Offset 0) (Offset 0) (Offset 0) f >>= freeze   where     srcLen = length src-    end = Offset 0 `offsetPlusE` Size srcLen+    end = Offset 0 `offsetPlusE` srcLen     fill srcI srcIdx dstIdx f' dst'         | srcI == end = return dst'         | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx                          fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst' --- | Length of a String using Size+-- | Length of a String using CountOf -- -- this size is available in o(n)-lengthSize :: String -> Size Char-lengthSize (String ba)-    | C.null ba = Size 0+length :: String -> CountOf Char+length (String ba)+    | C.null ba = CountOf 0     | otherwise = Vec.unsafeDewrap goVec goAddr ba   where-    goVec ma start = loop start (Size 0)+    goVec ma start = loop start (CountOf 0)       where-        !end = start `offsetPlusE` Vec.lengthSize ba+        !end = start `offsetPlusE` Vec.length ba         loop !idx !i             | idx >= end = i-            | otherwise  = loop (idx `offsetPlusE` d) (i + Size 1)+            | otherwise  = loop (idx `offsetPlusE` d) (i + CountOf 1)           where d = skipNextHeaderValue (primBaIndex ma idx) -    goAddr (Ptr ptr) start = return $ loop start (Size 0)+    goAddr (Ptr ptr) start = return $ loop start (CountOf 0)       where-        !end = start `offsetPlusE` Vec.lengthSize ba+        !end = start `offsetPlusE` Vec.length ba         loop !idx !i             | idx >= end = i-            | otherwise  = loop (idx `offsetPlusE` d) (i + Size 1)+            | otherwise  = loop (idx `offsetPlusE` d) (i + CountOf 1)           where d = skipNextHeaderValue (primAddrIndex ptr idx) --- | Length of a string in number of characters-length :: String -> Int-length s = let (Size sz) = lengthSize s in sz- -- | Replicate a character @c@ @n@ times to create a string of length @n@-replicate :: Word -> Char -> String-replicate n c = runST (new nbBytes >>= fill)+replicate :: CountOf Char -> Char -> String+replicate (CountOf n) c = runST (new nbBytes >>= fill)   where-    --end       = azero `offsetPlusE` nbBytes-    nbBytes   = scale n sz+    nbBytes   = scale (integralCast n :: Word) sz     sz = charToBytes (fromEnum c)     fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String     fill ms = loop (Offset 0)@@ -631,20 +648,22 @@ -- The callback @f@ needs to return the number of bytes filled in the underlaying -- bytes buffer. No check is made on the callback return values, and if it's not -- contained without the bounds, bad things will happen.-create :: PrimMonad prim => Int -> (MutableString (PrimState prim) -> prim Int) -> prim String+create :: PrimMonad prim => CountOf Word8 -> (MutableString (PrimState prim) -> prim (Offset Word8)) -> prim String create sz f = do-    ms     <- new (Size sz)+    ms     <- new sz     filled <- f ms-    if filled == sz+    if filled .==# sz         then freeze ms-        else take filled `fmap` freeze ms+        else do+            (String ba) <- freeze ms+            pure $ String $ C.take (offsetAsSize filled) ba  -- | Monomorphically map the character in a string and return the transformed one charMap :: (Char -> Char) -> String -> String charMap f src     | srcSz == 0 = mempty     | otherwise  =-        let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (Size 0)+        let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (CountOf 0)          in runST $ do                 dest <- new nbBytes                 copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes)@@ -665,7 +684,7 @@                     -- otherwise allocating less would bring the danger of spinning endlessly                     -- and never succeeding.                     let !diffBytes = srcEnd - idx-                        !allocatedBytes = if diffBytes <= Size 4 then Size 4 else diffBytes+                        !allocatedBytes = if diffBytes <= CountOf 4 then CountOf 4 else diffBytes                     ms <- new allocatedBytes                     (dstIdx, srcIdx) <- fill ms allocatedBytes idx                     s <- freeze ms@@ -704,7 +723,7 @@ -- | Append a Char to the end of the String and return this new String snoc :: String -> Char -> String snoc s@(String ba) c-    | len == Size 0 = singleton c+    | len == CountOf 0 = singleton c     | otherwise     = runST $ do         ms@(MutableString mba) <- new (len + nbBytes)         Vec.unsafeCopyAtRO mba (Offset 0) ba (Offset 0) len@@ -717,7 +736,7 @@ -- | Prepend a Char to the beginning of the String and return this new String cons :: Char -> String -> String cons c s@(String ba)-  | len == Size 0 = singleton c+  | len == CountOf 0 = singleton c   | otherwise     = runST $ do       ms@(MutableString mba) <- new (len + nbBytes)       idx <- write ms (Offset 0) c@@ -733,7 +752,7 @@ unsnoc :: String -> Maybe (String, Char) unsnoc s     | null s    = Nothing-    | otherwise = case index s (sizeLastOffset $ lengthSize s) of+    | otherwise = case index s (sizeLastOffset $ length s) of         Nothing -> Nothing         Just c  -> Just (revDrop 1 s, c) @@ -782,18 +801,18 @@         | didx == Offset 0 = freeze ms         | otherwise = do             let !h = Vec.unsafeIndex ba si-                !nb = Size (getNbBytes h + 1)+                !nb = CountOf (getNbBytes h + 1)                 d  = didx `offsetMinusE` nb             case nb of-                Size 1 -> Vec.unsafeWrite mba d h-                Size 2 -> do+                CountOf 1 -> Vec.unsafeWrite mba d h+                CountOf 2 -> do                     Vec.unsafeWrite mba d       h                     Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))-                Size 3 -> do+                CountOf 3 -> do                     Vec.unsafeWrite mba d       h                     Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))                     Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))-                Size 4 -> do+                CountOf 4 -> do                     Vec.unsafeWrite mba d       h                     Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex  ba (si + 1))                     Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))@@ -814,7 +833,7 @@   where     !nbBytes = size s     end = 0 `offsetPlusE` nbBytes-    ofs = indexN n s+    ofs = indexN (offsetAsSize n) s  -- | Return the index in unit of Char of the first occurence of the predicate returning True --@@ -873,10 +892,10 @@ fromBytes UTF8       bytes     | C.null bytes = (mempty, Nothing, mempty)     | otherwise    =-        case validate bytes (Offset 0) (Size $ C.length bytes) of+        case validate bytes (Offset 0) (C.length bytes) of             (_, Nothing)  -> (fromBytesUnsafe bytes, Nothing, mempty)-            (Offset pos, Just vf) ->-                let (b1, b2) = C.splitAt pos bytes+            (pos, Just vf) ->+                let (b1, b2) = C.splitAt (offsetAsSize pos) bytes                  in (fromBytesUnsafe b1, toErr vf, b2)   where     toErr MissingByte         = Nothing@@ -895,18 +914,18 @@ fromBytesLenient bytes     | C.null bytes = (mempty, mempty)     | otherwise    =-        case validate bytes (Offset 0) (Size $ C.length bytes) of+        case validate bytes (Offset 0) (C.length bytes) of             (_, Nothing)                   -> (fromBytesUnsafe bytes, mempty)-            (Offset pos, Just MissingByte) ->-                let (b1,b2) = C.splitAt pos bytes+            (pos, Just MissingByte) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes                  in (fromBytesUnsafe b1, b2)-            (Offset pos, Just InvalidHeader) ->-                let (b1,b2) = C.splitAt pos bytes+            (pos, Just InvalidHeader) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes                     (_,b3)  = C.splitAt 1 b2                     (s3, r) = fromBytesLenient b3                  in (mconcat [fromBytesUnsafe b1,replacement, s3], r)-            (Offset pos, Just InvalidContinuation) ->-                let (b1,b2) = C.splitAt pos bytes+            (pos, Just InvalidContinuation) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes                     (_,b3)  = C.splitAt 1 b2                     (s3, r) = fromBytesLenient b3                  in (mconcat [fromBytesUnsafe b1,replacement, s3], r)@@ -924,14 +943,14 @@   where     loop []         = []     loop (bytes:[]) =-        case validate bytes (Offset 0) (Size $ C.length bytes) of+        case validate bytes (Offset 0) (C.length bytes) of             (_, Nothing)  -> [fromBytesUnsafe bytes]             (_, Just err) -> doErr err     loop (bytes:cs@(c1:c2)) =-        case validate bytes (Offset 0) (Size $ C.length bytes) of+        case validate bytes (Offset 0) (C.length bytes) of             (_, Nothing) -> fromBytesUnsafe bytes : loop cs-            (Offset pos, Just MissingByte) ->-                let (b1,b2) = C.splitAt pos bytes+            (pos, Just MissingByte) ->+                let (b1,b2) = C.splitAt (offsetAsSize pos) bytes                  in fromBytesUnsafe b1 : loop ((b2 `mappend` c1) : c2)             (_, Just err) -> doErr err     doErr err = error ("fromChunkBytes: " <> show err)@@ -1001,18 +1020,18 @@     | sizeChunksI <= 3 = builderBuild 64 sb     | otherwise        = do         first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        ((), (i, st)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks)         cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)         -- Build final array         let totalSize = prevChunksSize st + offsetAsSize i         final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze         return $ String final   where-    sizeChunks = Size sizeChunksI+    sizeChunks = CountOf sizeChunksI      fillFromEnd _   []            mba = return mba     fillFromEnd !end (String x:xs) mba = do-        let sz = Vec.lengthSize x+        let sz = Vec.length x         Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz         fillFromEnd (end - sz) xs mba @@ -1148,9 +1167,9 @@          consumeFloat isNegative integral startOfs =             case decimalDigitsBA integral ba eofs startOfs of-                (# acc, True, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs                                                                 in f isNegative acc (integralCast diff) Nothing-                (# acc, False, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs                                                                 in consumeExponant isNegative acc (integralCast diff) endOfs                 _                                           -> Nothing @@ -1188,9 +1207,9 @@          consumeFloat isNegative integral startOfs =             case decimalDigitsPtr integral ptr eofs startOfs of-                (# acc, True, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                (# acc, True, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs                                                                 in f isNegative acc (integralCast diff) Nothing-                (# acc, False, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                (# acc, False, endOfs #) | endOfs > startOfs -> let (CountOf !diff) = endOfs - startOfs                                                                 in consumeExponant isNegative acc (integralCast diff) endOfs                 _                                           -> Nothing @@ -1303,3 +1322,39 @@ --   Does not properly support multicharacter Unicode conversions. lower :: String -> String lower = charMap toLower++-- | Check whether the first string is a prefix of the second string.+isPrefixOf :: String -> String -> Bool+isPrefixOf (String needle) (String haystack)+    | needleLen > hayLen = False+    | otherwise          = needle == C.take needleLen haystack+  where+    needleLen = C.length needle+    hayLen    = C.length haystack++-- | Check whether the first string is a suffix of the second string.+isSuffixOf :: String -> String -> Bool+isSuffixOf (String needle) (String haystack)+    | needleLen > hayLen = False+    | otherwise          = needle == C.revTake needleLen haystack+  where+    needleLen = C.length needle+    hayLen    = C.length haystack++-- | Check whether the first string is contains within the second string.+--+-- TODO: implemented the naive way and thus terribly inefficient, reimplement properly+isInfixOf :: String -> String -> Bool+isInfixOf (String needle) (String haystack)+    | needleLen > hayLen = False+    | otherwise          = loop 0+  where+    endOfs    = hayLen - needleLen+    needleLen = C.length needle+    hayLen    = C.length haystack++    loop i+        | i == endOfs           = needle == haystackSub+        | needle == haystackSub = True+        | otherwise             = loop (i+1)+      where haystackSub = C.take needleLen $ C.drop i $ haystack

@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} module Foundation.System.Bindings     ( module X

@@ -1,7 +1,24 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-} module Foundation.System.Bindings.Hs     where  import GHC.IO+import GHC.Prim import Foreign.C.Types+import Foreign.Ptr  foreign import ccall unsafe "HsBase.h __hscore_get_errno" sysHsCoreGetErrno :: IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa ::+    ByteArray# -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr ::+    ByteArray# -> CSize -> Ptr a -> CSize -> CSize -> IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa ::+    Ptr a -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt++foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr ::+    Ptr a -> CSize -> Ptr b -> CSize -> CSize -> IO CInt

@@ -11,14 +11,13 @@ -- Functions defined only for linux -- ------------------------------------------------------------------------------+{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Linux    where  import Foundation.Internal.Base import Foreign.C.Types import Foundation.System.Bindings.PosixDef-import Foundation.System.Bindings.Posix  #define __USE_GNU 

@@ -1,13 +1,18 @@+{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Macos     where  import Foundation.Internal.Base+import Foreign.C.Types import Foundation.System.Bindings.PosixDef+import Foundation.Primitive.Types.OffsetSize  #include <sys/mman.h> #include <sys/stat.h> #include <unistd.h> #include <fcntl.h>+#include <mach/mach.h>+#include <mach/mach_time.h>  sysMacos_O_SHLOCK     , sysMacos_O_EXLOCK@@ -17,3 +22,19 @@ sysMacos_O_EXLOCK   = (#const O_EXLOCK) sysMacos_O_SYMLINK  = (#const O_SYMLINK) sysMacos_O_EVTONLY  = (#const O_EVTONLY)++data MachTimebaseInfo++size_MachTimebaseInfo :: CSize+size_MachTimebaseInfo = #const sizeof(mach_timebase_info_data_t)++ofs_MachTimebaseInfo_numer :: Offset Word8+ofs_MachTimebaseInfo_numer = Offset (#offset mach_timebase_info_data_t, numer)++ofs_MachTimebaseInfo_denom :: Offset Word8+ofs_MachTimebaseInfo_denom = Offset (#offset mach_timebase_info_data_t, denom)++foreign import ccall unsafe "mach_absolute_time"+    sysMacos_absolute_time :: IO Word64+foreign import ccall unsafe "mach_timebase_info"+    sysMacos_timebase_info :: Ptr MachTimebaseInfo -> IO ()

@@ -5,6 +5,7 @@ -- Stability   :  provisional -- Portability :  portable --+{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Network     ( -- * error       getHErrno

@@ -11,7 +11,7 @@ -- Functions defined by the POSIX standards -- ------------------------------------------------------------------------------+{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Posix    where 

@@ -1,4 +1,4 @@-+{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.PosixDef     ( CErrno     , CFd

@@ -0,0 +1,114 @@+-- |+-- Module      :  Foundation.System.Bindings.Time+-- Maintainer  :  Haskell foundation+--++module Foundation.System.Bindings.Time where++import Foundation.Internal.Base+import Foundation.Primitive.Types.OffsetSize+import Foreign.C.Types++#include <time.h>+#include <sys/time.h>++type CClockId = CInt+data CTimeSpec+data CTimeVal+data CTimeZone++size_CTimeSpec :: CSize+size_CTimeSpec = #const sizeof(struct timespec)++ofs_CTimeSpec_Seconds :: Offset Word8+ofs_CTimeSpec_Seconds = Offset (#offset struct timespec, tv_sec)++ofs_CTimeSpec_NanoSeconds :: Offset Word8+ofs_CTimeSpec_NanoSeconds = Offset (#offset struct timespec, tv_nsec)++size_CTimeVal :: CSize+size_CTimeVal = #const sizeof(struct timeval)++size_CTimeZone :: CSize+size_CTimeZone = #const sizeof(struct timezone)++size_CTimeT :: CSize+size_CTimeT = #const sizeof(time_t)++#if defined __APPLE__++#include <Availability.h>++#if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12++#define CLOCK_REALTIME 0+#define CLOCK_MONOTONIC 1+#define CLOCK_PROCESS_CPUTIME_ID 2+#define CLOCK_THREAD_CPUTIME_ID 3++#define FOUNDATION_SYSTEM_API_NO_CLOCK++#endif++#endif++sysTime_CLOCK_REALTIME+    , sysTime_CLOCK_MONOTONIC :: CClockId+sysTime_CLOCK_REALTIME = (#const CLOCK_REALTIME)+sysTime_CLOCK_MONOTONIC = (#const CLOCK_MONOTONIC)++sysTime_CLOCK_PROCESS_CPUTIME_ID :: CClockId+sysTime_CLOCK_PROCESS_CPUTIME_ID = (#const CLOCK_PROCESS_CPUTIME_ID)++sysTime_CLOCK_THREAD_CPUTIME_ID :: CClockId+sysTime_CLOCK_THREAD_CPUTIME_ID = (#const CLOCK_THREAD_CPUTIME_ID)++#ifdef CLOCK_MONOTONIC_RAW+sysTime_CLOCK_MONOTONIC_RAW :: CClockId+sysTime_CLOCK_MONOTONIC_RAW = (#const CLOCK_MONOTONIC_RAW)+#endif++#ifdef CLOCK_REALTIME_COARSE+sysTime_CLOCK_REALTIME_COARSE :: CClockId+sysTime_CLOCK_REALTIME_COARSE = (#const CLOCK_REALTIME_COARSE)+#endif++#ifdef CLOCK_MONOTIC_COARSE+sysTime_CLOCK_MONOTONIC_COARSE :: CClockId+sysTime_CLOCK_MONOTONIC_COARSE = (#const CLOCK_MONOTONIC_COARSE)+#endif++#ifdef CLOCK_BOOTTIME+sysTime_CLOCK_BOOTTIME :: CClockId+sysTime_CLOCK_BOOTTIME = (#const CLOCK_BOOTTIME)+#endif++#ifdef CLOCK_REALTIME_ALARM+sysTime_CLOCK_REALTIME_ALARM :: CClockId+sysTime_CLOCK_REALTIME_ALARM = (#const CLOCK_REALTIME_ALARM)+#endif++#ifdef CLOCK_BOOTTIME_ALARM+sysTime_CLOCK_BOOTTIME_ALARM :: CClockId+sysTime_CLOCK_BOOTTIME_ALARM = (#const CLOCK_BOOTTIME_ALARM)+#endif++#ifdef CLOCK_TAI+sysTime_CLOCK_TAI :: CClockId+sysTime_CLOCK_TAI = (#const CLOCK_TAI)+#endif++#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK+foreign import ccall unsafe "foundation_time_clock_getres"+    sysTimeClockGetRes :: CClockId -> Ptr CTimeSpec -> IO CInt+foreign import ccall unsafe "foundation_time_clock_gettime"+    sysTimeClockGetTime :: CClockId -> Ptr CTimeSpec -> IO CInt+#else+foreign import ccall unsafe "clock_getres"+    sysTimeClockGetRes :: CClockId -> Ptr CTimeSpec -> IO CInt+foreign import ccall unsafe "clock_gettime"+    sysTimeClockGetTime :: CClockId -> Ptr CTimeSpec -> IO CInt+#endif++foreign import ccall unsafe "gettimeofday"+    sysTimeGetTimeOfDay :: Ptr CTimeVal -> Ptr CTimeZone -> IO CInt

@@ -1,2 +1,3 @@+{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Windows      where

@@ -27,8 +27,8 @@ #endif  -- | Get some of the system entropy-getEntropy :: Size Word8 -> IO (A.UArray Word8)-getEntropy n@(Size x) = do+getEntropy :: CountOf Word8 -> IO (A.UArray Word8)+getEntropy n@(CountOf x) = do     m <- A.newPinned n     bracket entropyOpen entropyClose $ \ctx -> A.withMutablePtr m $ loop ctx x     A.unsafeFreeze m

@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module Foundation.Time.Bindings+    ( measuringNanoSeconds+    , getMonotonicTime+    ) where++import Foundation.Primitive.Imports+import Foundation.Primitive.Types.OffsetSize+import Foundation.Primitive.Types.Ptr+import Foundation.System.Bindings.Time+import Foundation.Time.Types+import Foundation.Foreign.Alloc+import Foreign.Storable++measuringNanoSeconds :: IO a -> IO (a, NanoSeconds)+measuringNanoSeconds f =+    allocaBytes (sizeOfCSize size_CTimeSpec) $ \t1 ->+    allocaBytes (sizeOfCSize size_CTimeSpec) $ \t2 -> do+        _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC t1+        r <- f+        _err2 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC t2+        return (r, NanoSeconds 0)++getMonotonicTime :: IO (Seconds, NanoSeconds)+getMonotonicTime =+    allocaBytes (sizeOfCSize size_CTimeSpec) $ \tspec -> do+        _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC tspec+        s  <- Seconds     <$> peek (castPtr (tspec `ptrPlus` ofs_CTimeSpec_Seconds))+        ns <- NanoSeconds <$> peek (castPtr (tspec `ptrPlus` ofs_CTimeSpec_NanoSeconds))+        return (s,ns)

@@ -0,0 +1,113 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Foundation.Time.StopWatch+    ( StopWatchPrecise+    , startPrecise+    , stopPrecise+    ) where++import Foundation.Primitive.Imports+import Foundation.Primitive.Types.Ptr+import Foundation.Time.Types+import Foundation.Primitive.Block.Mutable+import Foundation.Numerical+import Foreign.Storable++#if defined(mingw32_HOST_OS)+import System.Win32.Time+import Foundation.Primitive.Monad+import Foundation.Primitive.IntegralConv+import System.IO.Unsafe+#elif defined(darwin_HOST_OS)+import Foundation.System.Bindings.Macos+import Foundation.Primitive.IntegralConv+import System.IO.Unsafe+import Foundation.Primitive.Types.OffsetSize+#else+import Foundation.System.Bindings.Time+import Foundation.Primitive.Monad+import Foundation.Primitive.Types.OffsetSize+#endif++-- | A precise stop watch+--+-- The precision is higher than a normal stopwatch, but+-- also on some system it might not be able to record+-- longer period of time accurately (possibly wrapping)+newtype StopWatchPrecise =+#if defined(darwin_HOST_OS)+    StopWatchPrecise Word64+#elif defined(mingw32_HOST_OS)+    -- contain 2 LARGE_INTEGER (int64_t)+    StopWatchPrecise (MutableBlock Word8 (PrimState IO))+#else+    -- contains 2 timespec (16 bytes)+    StopWatchPrecise (MutableBlock Word8 (PrimState IO))+#endif++#if defined(mingw32_HOST_OS)+initPrecise :: Word64+initPrecise = unsafePerformIO $ integralDownsize <$> queryPerformanceFrequency+{-# NOINLINE initPrecise #-}+#elif defined(darwin_HOST_OS)+initPrecise :: (Word64, Word64)+initPrecise = unsafePerformIO $ do+    mti <- newPinned (sizeOfCSize size_MachTimebaseInfo)+    p   <- mutableGetAddr mti +    sysMacos_timebase_info (castPtr p)+    let p32 = castPtr p :: Ptr Word32+    !n <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_numer)+    !d <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_denom)+    -- touch mti ..+    pure (integralUpsize n, integralUpsize d)+{-# NOINLINE initPrecise #-}+#endif++-- | Create a new precise stop watch+--+-- record the time at start of call+startPrecise :: IO StopWatchPrecise+startPrecise = do+#if defined(mingw32_HOST_OS)+    blk <- newPinned 16+    p   <- mutableGetAddr blk+    _ <- c_QueryPerformanceCounter (castPtr p `ptrPlus` 8)+    pure (StopWatchPrecise blk)+#elif defined(darwin_HOST_OS)+    StopWatchPrecise <$> sysMacos_absolute_time+#else+    blk <- newPinned (sizeOfCSize (size_CTimeSpec + size_CTimeSpec))+    p   <- mutableGetAddr blk+    _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p `ptrPlusCSz` size_CTimeSpec)+    pure (StopWatchPrecise blk)+#endif++-- | Get the number of nano seconds since the call to `startPrecise`+stopPrecise :: StopWatchPrecise -> IO NanoSeconds+stopPrecise (StopWatchPrecise blk) = do+#if defined(mingw32_HOST_OS)+    p <- mutableGetAddr blk+    _ <- c_QueryPerformanceCounter (castPtr p)+    let p64 = castPtr p :: Ptr Word64+    end   <- peek p64+    start <- peek (p64 `ptrPlus` 8)+    pure $ NanoSeconds $ ((end - start) * secondInNano `div` initPrecise)+#elif defined(darwin_HOST_OS)+    end <- sysMacos_absolute_time+    pure $ NanoSeconds $ case initPrecise of+        (1,1)         -> end - blk+        (numer,denom) -> ((end - blk) * numer) `div` denom+#else+    p <- mutableGetAddr blk+    _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p)+    let p64 = castPtr p :: Ptr Word64+    endSec    <- peek p64+    startSec  <- peek (p64 `ptrPlusCSz` size_CTimeSpec)+    endNSec   <- peek (p64 `ptrPlus` ofs_CTimeSpec_NanoSeconds)+    startNSec <- peek (p64 `ptrPlus` (sizeAsOffset (sizeOfCSize size_CTimeSpec) + ofs_CTimeSpec_NanoSeconds))+    pure $ NanoSeconds $ (endSec * secondInNano + endNSec) - (startSec * secondInNano + startNSec)+#endif++secondInNano :: Word64+secondInNano = 1000000000

@@ -0,0 +1,44 @@+-- |+-- Module      : Foundation.Timing+-- License     : BSD-style+-- Maintainer  : Foundation maintainers+--+-- An implementation of a timing framework+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Foundation.Time.Types+    ( NanoSeconds(..)+    , Seconds(..)+    ) where++import           Foundation.Internal.Proxy+import           Foundation.Primitive.Imports+import           Foundation.Primitive.Types+import           Foundation.Numerical+import           Data.Coerce++-- | An amount of nanoseconds+newtype NanoSeconds = NanoSeconds Word64+    deriving (Show,Eq,Ord,Additive,Enum,Bounded)++instance PrimType NanoSeconds where+    primSizeInBytes _        = primSizeInBytes (Proxy :: Proxy Word64)+    primBaUIndex ba ofs      = primBaUIndex ba (coerce ofs)+    primMbaURead mba ofs     = primMbaURead mba (coerce ofs)+    primMbaUWrite mba ofs v  = primMbaUWrite mba (coerce ofs) (coerce v :: Word64)+    primAddrIndex addr ofs   = primAddrIndex addr (coerce ofs)+    primAddrRead addr ofs    = primAddrRead addr (coerce ofs)+    primAddrWrite addr ofs v = primAddrWrite addr (coerce ofs) (coerce v :: Word64)++-- | An amount of nanoseconds+newtype Seconds = Seconds Word64+    deriving (Show,Eq,Ord,Additive,Enum,Bounded)++instance PrimType Seconds where+    primSizeInBytes _        = primSizeInBytes (Proxy :: Proxy Word64)+    primBaUIndex ba ofs      = primBaUIndex ba (coerce ofs)+    primMbaURead mba ofs     = primMbaURead mba (coerce ofs)+    primMbaUWrite mba ofs v  = primMbaUWrite mba (coerce ofs) (coerce v :: Word64)+    primAddrIndex addr ofs   = primAddrIndex addr (coerce ofs)+    primAddrRead addr ofs    = primAddrRead addr (coerce ofs)+    primAddrWrite addr ofs v = primAddrWrite addr (coerce ofs) (coerce v :: Word64)

@@ -0,0 +1,68 @@+-- |+-- Module      : Foundation.Timing+-- License     : BSD-style+-- Maintainer  : Foundation maintainers+--+-- An implementation of a timing framework+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Foundation.Timing+    ( Timing(..)+    , Measure(..)+    , stopWatch+    , measure+    ) where++import           Foundation.Primitive.Imports+import           Foundation.Primitive.IntegralConv+import           Foundation.Primitive.Monad+-- import           Foundation.Array.Unboxed hiding (unsafeFreeze)+import           Foundation.Array.Unboxed.Mutable (MUArray)+import           Foundation.Collection+import           Foundation.Time.Types+import           Foundation.Numerical+import           Foundation.Time.Bindings+import           Control.Exception (evaluate)+import           System.Mem (performGC)+import           Data.Function (on)+import qualified GHC.Stats as GHC+++data Timing = Timing+    { timeDiff           :: !NanoSeconds+    , timeBytesAllocated :: !(Maybe Int64)+    }++data Measure = Measure+    { measurements :: UArray NanoSeconds+    , iters        :: Word+    }++getGCStats :: IO (Maybe GHC.GCStats)+getGCStats = do+    r <- GHC.getGCStatsEnabled+    if r then pure Nothing else Just <$> GHC.getGCStats++-- | Simple one-time measurement of time & other metrics spent in a function+stopWatch :: (a -> b) -> a -> IO Timing+stopWatch f !a = do+    performGC+    gc1 <- getGCStats+    (_, ns) <- measuringNanoSeconds (evaluate $ f a)+    gc2 <- getGCStats+    return $ Timing ns (((-) `on` GHC.bytesAllocated) <$> gc2 <*> gc1)++-- | In depth timing & other metrics analysis of a function+measure :: Word -> (a -> b) -> a -> IO Measure+measure nbIters f a = do+    d <- mutNew (integralCast nbIters) :: IO (MUArray NanoSeconds (PrimState IO))+    loop d 0+    Measure <$> unsafeFreeze d+            <*> pure nbIters+  where+    loop d !i+        | i == nbIters = return ()+        | otherwise    = do+            (_, r) <- measuringNanoSeconds (evaluate $ f a)+            mutUnsafeWrite d (integralCast i) r+            loop d (i+1)

@@ -0,0 +1,64 @@+-- |+-- Module      : Foundation.Timing.Main+-- License     : BSD-style+-- Maintainer  : Foundation maintainers+--+-- An implementation of a timing framework+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+module Foundation.Timing.Main+    ( defaultMain+    ) where++import           Foundation.Primitive.Imports+import           Foundation.IO.Terminal+import           Foundation.Collection+import           Control.Monad (when)++data MainConfig = MainConfig+    { mainHelp       :: Bool+    , mainListBenchs :: Bool+    , mainVerbose    :: Bool+    , mainOther      :: [String]+    }++newtype TimingPlan a = TimingPlan { runTimingPlan :: IO a }+    deriving (Functor, Applicative, Monad)++defaultMainConfig :: MainConfig+defaultMainConfig = MainConfig+    { mainHelp       = False+    , mainListBenchs = False+    , mainVerbose    = False+    , mainOther      = []+    }++parseArgs :: [String] -> MainConfig -> Either String MainConfig+parseArgs []                cfg    = Right cfg+parseArgs ("--list-benchs":xs) cfg = parseArgs xs $ cfg { mainListBenchs = True }+parseArgs ("--verbose":xs) cfg     = parseArgs xs $ cfg { mainVerbose = True }+parseArgs ("--help":xs)    cfg     = parseArgs xs $ cfg { mainHelp = True }+parseArgs (x:xs)           cfg     = parseArgs xs $ cfg { mainOther = x : mainOther cfg }++configHelp :: [String]+configHelp = []++defaultMain :: TimingPlan () -> IO ()+defaultMain tp = do+    ecfg <- flip parseArgs defaultMainConfig <$> getArgs+    cfg  <- case ecfg of+            Left e  -> do+                putStrLn e+                mapM_ putStrLn configHelp+                exitFailure+            Right c -> pure c++    when (mainHelp cfg) (mapM_ putStrLn configHelp >> exitSuccess)+    when (mainListBenchs cfg) (printAll >> exitSuccess)++    runTimingPlan tp++    return ()+  where+    printAll = undefined

@@ -1,4 +1,5 @@-Copyright (c) 2015-2016 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2015-2017 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2017      Foundation Maintainers  All rights reserved. 

@@ -5,6 +5,7 @@ [![Coverage Status](https://coveralls.io/repos/github/haskell-foundation/foundation/badge.svg?branch=master)](https://coveralls.io/github/haskell-foundation/foundation?branch=master) [![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) [![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org)+[![Doc](https://readthedocs.org/projects/haskell-foundation/badge/?version=latest)](http://haskell-foundation.readthedocs.io/en/latest/)  Documentation: [foundation on hackage](http://hackage.haskell.org/package/foundation) 

@@ -83,11 +83,11 @@         fmap (\(n, dat) -> bgroup n $ diffTextString (elem '.') (Text.any (== '.')) dat)             allDat     benchTake = bgroup "Take" $ mconcat $ fmap (\p ->-        fmap (\(n, dat) -> bgroup n $ diffTextString (take p) (Text.take p) dat)+        fmap (\(n, dat) -> bgroup n $ diffTextString (take (CountOf p)) (Text.take p) dat)                 $ allDatSuffix (show p)             ) [ 10, 100, 800 ]     benchSplitAt = bgroup "SplitAt" $ mconcat $ fmap (\p ->-        fmap (\(n, dat) -> bgroup n $ diffTextString (fst . splitAt p) (fst . Text.splitAt p) dat)+        fmap (\(n, dat) -> bgroup n $ diffTextString (fst . splitAt (CountOf p)) (fst . Text.splitAt p) dat)                 $ allDatSuffix (show p)             ) [ 10, 100, 800 ] @@ -170,7 +170,7 @@         fmap (\(n, dat) -> bgroup n $ diffByteString length ByteString.length dat) allDat      benchTake = bgroup "Take" $ mconcat $ fmap (\p ->-        fmap (\(n, dat) -> bgroup n $ diffByteString (take p) (ByteString.take p) dat)+        fmap (\(n, dat) -> bgroup n $ diffByteString (take (CountOf p)) (ByteString.take p) dat)             $ allDatSuffix (show p)         ) [ 0, 10, 100 ] 

@@ -18,7 +18,7 @@ instance RandomGen NullRandom where     randomNew        = return NullRandom     randomNewFrom    = error "no randomNewFrom"-    randomGenerate (Size n) r = (fromList (Prelude.replicate n 0), r)+    randomGenerate (CountOf n) r = (fromList (Prelude.replicate n 0), r)  benchSys =     [ bgroup "Random"@@ -29,9 +29,9 @@     , bgroup "RNGv1"         [ bench "Entropy-1"     $ benchRandom 1 randomNew (Proxy :: Proxy RNGv1)         , bench "Entropy-1024"  $ benchRandom 1024 randomNew (Proxy :: Proxy RNGv1)-        , bench "Entropy-1M"    $ benchRandom (Size (1024 * 1024)) randomNew (Proxy :: Proxy RNGv1)+        , bench "Entropy-1M"    $ benchRandom (CountOf (1024 * 1024)) randomNew (Proxy :: Proxy RNGv1)         ]     ] -benchRandom :: RandomGen rng => Size Word8 -> MonadRandomState NullRandom rng -> Proxy rng -> Benchmarkable+benchRandom :: RandomGen rng => CountOf Word8 -> MonadRandomState NullRandom rng -> Proxy rng -> Benchmarkable benchRandom n rNew _ = whnf (fst . randomGenerate n) (fst $ withRandomGenerator NullRandom rNew)

@@ -0,0 +1,6 @@+#include <string.h>++int _foundation_memcmp(const void *s1, size_t off1, const void *s2, size_t off2, size_t n)+{+	return memcmp(s1 + off1, s2 + off2, n);+}

@@ -119,13 +119,13 @@  	if (!bytes) 		return 0;-	for (; bytes >= 64; bytes -= 64, dst += 64) {+	for (; bytes >= CHACHA_OUTPUT_SIZE; bytes -= CHACHA_OUTPUT_SIZE, dst += CHACHA_OUTPUT_SIZE) { 		chacha_core(rounds, dst, key, nonce); 		if (++nonce[0] == 0) 			nonce[1]++; 	} -	assert(bytes < 64);+	assert(bytes < CHACHA_OUTPUT_SIZE);  	chacha_core(rounds, buf, key, nonce); 	int remaining = CHACHA_OUTPUT_SIZE - bytes;

@@ -13,9 +13,15 @@    #endif #elif __APPLE__     #include "TargetConditionals.h"+    #include "Availability.h"+     #if TARGET_OS_MAC       #define FOUNDATION_SYSTEM_UNIX       #define FOUNDATION_SYSTEM_MACOS++      #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12+      #define FOUNDATION_SYSTEM_API_NO_CLOCK+      #endif       // Other kinds of Mac OS     #else     #   error "foundation: system: Unknown Apple platform"

@@ -0,0 +1,84 @@+#include "foundation_system.h"++#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK++#ifdef FOUNDATION_SYSTEM_MACOS+#include <time.h>+#include <mach/clock.h>+#include <mach/mach.h>+#include <mach/mach_time.h>++/* OSX MONOTONIC COMPAT:+ * http://web.archive.org/web/20100517095152/http://www.wand.net.nz/~smr26/wordpress/2009/01/19/monotonic-time-in-mac-os-x/comment-page-1/+ */+++typedef enum {+	CLOCK_REALTIME,+	CLOCK_MONOTONIC,+	CLOCK_PROCESS_CPUTIME_ID,+	CLOCK_THREAD_CPUTIME_ID+} clockid_t;+++static mach_timebase_info_data_t timebase = {0,0};++int foundation_time_clock_getres(unsigned int clockid, struct timespec *timespec)+{+	switch (clockid) {+	/* clockid = 1 (CLOCK_MONOTONIC), or any other value */+	case CLOCK_MONOTONIC:+		if (timebase.denom == 0) mach_timebase_info(&timebase);+		timespec->tv_sec = 0;+		timespec->tv_nsec = timebase.numer / timebase.denom;+		break;+	/* clockid = 0 (CLOCK_REALTIME), or any other value */+	case CLOCK_REALTIME:+		return -1;+	}+	return -1;+}++int foundation_time_clock_gettime(unsigned int clockid, struct timespec *timespec)+{+	clock_serv_t cclock;+	mach_timespec_t mts;++	switch (clockid) {+#if 0+	case CLOCK_MONOTONIC: {+		uint64_t t, nanos;+		if (timebase.denom == 0) mach_timebase_info(timebase);++		t = mach_absolute_time();+		nanos = t * (timebase.numer / timebase.denom);++		timespec->tv_sec = t / 1e9;+		timespec->tv_nsec = t % 1e9;+		break;+	case CLOCK_PROCESS_CPUTIME_ID:+		break;+#endif+	case CLOCK_MONOTONIC:+		host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &cclock);+		clock_get_time(cclock, &mts);+		mach_port_deallocate(mach_task_self(), cclock);+		timespec->tv_sec = mts.tv_sec;+		timespec->tv_nsec = mts.tv_nsec;+		break;+	case CLOCK_REALTIME:+		host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock);+		clock_get_time(cclock, &mts);+		mach_port_deallocate(mach_task_self(), cclock);+		timespec->tv_sec = mts.tv_sec;+		timespec->tv_nsec = mts.tv_nsec;+		break;+	default:+		return -1;+	}+	return 0;+}++#endif++#endif

@@ -1,7 +1,7 @@-Name:                foundation-Version:             0.0.9-Synopsis:            Alternative prelude with batteries and no dependencies-Description:+name:                foundation+version:             0.0.10+synopsis:            Alternative prelude with batteries and no dependencies+description:     A custom prelude with no dependencies apart from base.     .     This package has the following goals:@@ -19,52 +19,53 @@     * Better I/O system with less Lazy IO     .     * Usual partial functions distinguished through type system-License:             BSD3-License-file:        LICENSE-Copyright:           Vincent Hanquez <vincent@snarc.org>-Author:              Vincent Hanquez <vincent@snarc.org>-Maintainer:          vincent@snarc.org-Category:            foundation-Stability:           experimental-Build-Type:          Simple-Homepage:            https://github.com/haskell-foundation/foundation-Bug-Reports:         https://github.com/haskell-foundation/foundation/issues-Cabal-Version:       >=1.10-tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2-extra-source-files:  README.md-                     cbits/*.h+license:             BSD3+license-file:        LICENSE+copyright:           2015-2017 Vincent Hanquez <vincent@snarc.org>+                     2017      Foundation Maintainers+author:              Vincent Hanquez <vincent@snarc.org>+maintainer:          vincent@snarc.org+category:            foundation+build-type:          Simple+homepage:            https://github.com/haskell-foundation/foundation+bug-reports:         https://github.com/haskell-foundation/foundation/issues+cabal-version:       >=1.10+tested-with:         GHC==8.0.2, GHC==7.10.3, GHC==7.8.4+extra-source-files:  cbits/*.h+extra-doc-files:     README.md+                     CHANGELOG.md  source-repository head   type: git-  location: https://github.com/haskell-foundation/foundation+  location: https://github.com/haskell-foundation/foundation.git -Flag experimental-  Description:       Enable building experimental features, known as highly unstable or without good support cross-platform-  Default:           False-  Manual:            True+flag experimental+  description:       Enable building experimental features, known as highly unstable or without good support cross-platform+  default:           False+  manual:            True -Flag bench-all-  Description:       Add some comparaison benchmarks against other haskell libraries-  Default:           False-  Manual:            True+flag bench-all+  description:       Add some comparaison benchmarks against other haskell libraries+  default:           False+  manual:            True -Flag minimal-deps-  Description:       Build fully with minimal deps (no criterion, no quickcheck, no doctest)-  Default:           False-  Manual:            True+flag minimal-deps+  description:       Build fully with minimal deps (no criterion, no quickcheck, no doctest)+  default:           False+  manual:            True -Flag bounds-check-  Description:       Add extra friendly boundary check for unsafe array operations-  Default:           False-  Manual:            True+flag bounds-check+  description:       Add extra friendly boundary check for unsafe array operations+  default:           False+  manual:            True -Flag doctest-  Description:       Add extra friendly boundary check for unsafe array operations-  Default:           False-  Manual:            True+flag doctest+  description:       Add extra friendly boundary check for unsafe array operations+  default:           False+  manual:            True -Library-  Exposed-modules:   Foundation+library+  exposed-modules:   Foundation                      Foundation.Numerical                      Foundation.Array                      Foundation.Array.Internal@@ -79,6 +80,7 @@                      Foundation.String.Read                      Foundation.IO                      Foundation.IO.FileMap+                     Foundation.IO.Terminal                      Foundation.VFS                      Foundation.VFS.Path                      Foundation.VFS.FilePath@@ -100,10 +102,16 @@                      Foundation.Parser                      Foundation.Random                      Foundation.Check+                     Foundation.Check.Main+                     Foundation.Timing+                     Foundation.Timing.Main+                     Foundation.Time.Types+                     Foundation.Time.Bindings+                     Foundation.Time.StopWatch                      Foundation.UUID                      Foundation.System.Entropy                      Foundation.System.Bindings-  Other-modules:     Foundation.Boot.Builder+  other-modules:     Foundation.Boot.Builder                      Foundation.Boot.List                      Foundation.String.Internal                      Foundation.String.UTF8@@ -119,8 +127,11 @@                      Foundation.Hashing.Hasher                      Foundation.Hashing.Hashable                      Foundation.Check.Gen+                     Foundation.Check.Print                      Foundation.Check.Arbitrary                      Foundation.Check.Property+                     Foundation.Check.Config+                     Foundation.Check.Types                      Foundation.Collection.Buildable                      Foundation.Collection.List                      Foundation.Collection.Element@@ -156,7 +167,6 @@                      Foundation.Numerical.Multiplicative                      Foundation.Numerical.Floating                      Foundation.IO.File-                     Foundation.IO.Terminal                      Foundation.Primitive.Base16                      Foundation.Primitive.Block.Base                      Foundation.Primitive.Block.Mutable@@ -164,6 +174,7 @@                      Foundation.Primitive.Exception                      Foundation.Primitive.Types                      Foundation.Primitive.Types.OffsetSize+                     Foundation.Primitive.Types.Ptr                      Foundation.Primitive.Monad                      Foundation.Primitive.NormalForm                      Foundation.Primitive.Utils@@ -188,67 +199,72 @@                      Foundation.Array.Unboxed.ByteArray                      Foundation.Array.Boxed                      Foundation.Array.Bitmap+                     Foundation.Foreign.Alloc                      Foundation.Foreign.MemoryMap                      Foundation.Foreign.MemoryMap.Types                      Foundation.Partial+                     -- Foundation.Time.Bindings                      Foundation.System.Entropy.Common                      Foundation.System.Bindings.Network+                     Foundation.System.Bindings.Time+                     Foundation.System.Bindings.Hs    include-dirs:      cbits-  C-sources:         cbits/foundation_random.c+  c-sources:         cbits/foundation_random.c                      cbits/foundation_network.c+                     cbits/foundation_mem.c+                     cbits/foundation_time.c    if flag(experimental)-    Exposed-modules: Foundation.Network.HostName+    exposed-modules: Foundation.Network.HostName   if os(windows)-    Exposed-modules: Foundation.System.Bindings.Windows-    Other-modules:   Foundation.Foreign.MemoryMap.Windows+    exposed-modules: Foundation.System.Bindings.Windows+    other-modules:   Foundation.Foreign.MemoryMap.Windows                      Foundation.System.Entropy.Windows   else-    Exposed-modules: Foundation.System.Bindings.Posix+    exposed-modules: Foundation.System.Bindings.Posix                      Foundation.System.Bindings.PosixDef-                     Foundation.System.Bindings.Hs-    Other-modules:   Foundation.Foreign.MemoryMap.Posix+    other-modules:   Foundation.Foreign.MemoryMap.Posix                      Foundation.System.Entropy.Unix   if os(linux)-    Exposed-modules: Foundation.System.Bindings.Linux+    exposed-modules: Foundation.System.Bindings.Linux   if os(osx)-    Exposed-modules: Foundation.System.Bindings.Macos+    exposed-modules: Foundation.System.Bindings.Macos    if impl(ghc >= 7.10)-    Exposed-modules: Foundation.Tuple.Nth+    exposed-modules: Foundation.Tuple.Nth                      Foundation.List.SList                      Foundation.Primitive.Nat -  Default-Extensions: NoImplicitPrelude+  default-extensions: NoImplicitPrelude                       RebindableSyntax                       TypeFamilies                       BangPatterns                       DeriveDataTypeable-  Build-depends:     base >= 4.7 && < 5+  build-depends:     base >= 4.7 && < 5                    , ghc-prim   -- FIXME add suport for armel mipsel   --  CPP-options: -DARCH_IS_LITTLE_ENDIAN   -- FIXME add support for powerpc powerpc64 armeb mipseb   --  CPP-options: -DARCH_IS_BIG_ENDIAN   if (arch(i386) || arch(x86_64))-    CPP-options: -DARCH_IS_LITTLE_ENDIAN+    cpp-options: -DARCH_IS_LITTLE_ENDIAN   else-    CPP-options: -DARCH_IS_UNKNOWN_ENDIAN+    cpp-options: -DARCH_IS_UNKNOWN_ENDIAN   if os(windows)-    Build-depends:    Win32+    build-depends:    Win32   ghc-options:       -Wall -fwarn-tabs   default-language:  Haskell2010   if impl(ghc >= 8.0)     ghc-options:     -Wno-redundant-constraints   if flag(bounds-check)-    CPP-options: -DFOUNDATION_BOUNDS_CHECK+    cpp-options: -DFOUNDATION_BOUNDS_CHECK -Test-Suite test-foundation+test-suite test-foundation   type:              exitcode-stdio-1.0   hs-source-dirs:    tests-  Main-is:           Tests.hs-  Other-modules:     Test.Utils.Foreign+  main-is:           Tests.hs+  other-modules:     Test.Utils.Foreign                      Test.Data.List                      Test.Data.Network                      Test.Data.Unicode@@ -265,15 +281,14 @@                      Test.Foundation.Array                      Test.Foundation.String                      Test.Foundation.Storable-                     Test.Foundation.Random                      Test.Foundation.Misc                      Imports-  Default-Extensions: NoImplicitPrelude+  default-extensions: NoImplicitPrelude                       RebindableSyntax   if flag(minimal-deps)-    Buildable: False+    buildable: False   else-    Build-Depends:   base >= 3 && < 5+    build-depends:   base >= 3 && < 5                    , mtl                    , QuickCheck                    , tasty@@ -285,42 +300,43 @@   if impl(ghc >= 8.0)     ghc-options:     -Wno-redundant-constraints -Test-Suite check-foundation+test-suite check-foundation   type:              exitcode-stdio-1.0   hs-source-dirs:    tests-  Main-is:           Checks.hs-  Other-modules:      Test.Checks.Property.Collection-  Default-Extensions: NoImplicitPrelude+  main-is:           Checks.hs+  other-modules:     Test.Checks.Property.Collection+                     Test.Foundation.Random+  default-extensions: NoImplicitPrelude                       RebindableSyntax                       OverloadedStrings-  Build-Depends:     base >= 3 && < 5+  build-depends:     base >= 3 && < 5                    , foundation   ghc-options:       -Wall -fno-warn-orphans -fno-warn-missing-signatures   default-language:  Haskell2010   if impl(ghc >= 8.0)     ghc-options:     -Wno-redundant-constraints -Test-Suite doctest+test-suite doctest   type:              exitcode-stdio-1.0   hs-source-dirs:    tests   default-language:  Haskell2010-  Main-is:           DocTest.hs-  Default-Extensions: NoImplicitPrelude+  main-is:           DocTest.hs+  default-extensions: NoImplicitPrelude                       RebindableSyntax   if flag(minimal-deps)     -- TODO: for no, force unbuildable anyway-    Buildable:       False+    buildable:       False   else     if flag(doctest)-      Build-Depends:     base >= 3 && < 5+      build-depends:     base >= 3 && < 5                        , doctest >= 0.9-      Buildable:     True+      buildable:     True     else-      Buildable:     False+      buildable:     False  Benchmark bench-  Main-Is:           Main.hs-  Other-modules:     BenchUtil.Common+  main-is:           Main.hs+  other-modules:     BenchUtil.Common                      BenchUtil.RefData                      Sys                      Fake.ByteString@@ -328,12 +344,12 @@   hs-source-dirs:    benchs   default-language:  Haskell2010   type:              exitcode-stdio-1.0-  Default-Extensions: NoImplicitPrelude+  default-extensions: NoImplicitPrelude                       BangPatterns   if flag(minimal-deps) || impl(ghc < 7.10)-    Buildable: False+    buildable: False   else-    Build-depends:     base >= 4, criterion, foundation+    build-depends:     base >= 4, criterion, foundation     if flag(bench-all)-      CPP-Options:     -DBENCH_ALL-      Build-depends:   text, attoparsec, vector, bytestring+      cpp-options:     -DBENCH_ALL+      build-depends:   text, attoparsec, vector, bytestring

@@ -11,11 +11,13 @@ import Foundation.List.DList import Foundation.Primitive import Foundation.Check+import Foundation.Check.Main (defaultMain) import Foundation.String import Foundation.String.Read import qualified Prelude import Data.Ratio +import Test.Foundation.Random import Test.Checks.Property.Collection  applyFstToSnd :: (String, String -> b) -> b@@ -170,4 +172,5 @@       [ matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb ->             \s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy ChunkedUArray) prx) arb       ]+    , testRandom     ]

@@ -28,15 +28,15 @@ instance Arbitrary IPv4 where     arbitrary = genIPv4 instance Foreign.Storable IPv4 where-    sizeOf a = let Size b = F.size (Just a) in b-    alignment a = let Size b = F.alignment (Just a) in b+    sizeOf a = let CountOf b = F.size (Just a) in b+    alignment a = let CountOf b = F.alignment (Just a) in b     peek = F.peek     poke = F.poke instance Arbitrary IPv6 where     arbitrary = genIPv6 instance Foreign.Storable IPv6 where-    sizeOf a = let Size b = F.size (Just a) in b-    alignment a = let Size b = F.alignment (Just a) in b+    sizeOf a = let CountOf b = F.size (Just a) in b+    alignment a = let CountOf b = F.alignment (Just a) in b     peek = F.peek     poke = F.poke 

@@ -52,10 +52,10 @@     [ testProperty "equal" $ withElementsM $ \fptr l ->         return $ toArrayP proxy l == foreignMem fptr (length l)     , testProperty "take" $ withElementsM $ \fptr l -> do-        n <- pick arbitrary+        n <- CountOf <$> pick arbitrary         return $ take n (toArrayP proxy l) == take n (foreignMem fptr (length l))     , testProperty "take" $ withElementsM $ \fptr l -> do-        n <- pick arbitrary+        n <- CountOf <$> pick arbitrary         return $ drop n (toArrayP proxy l) == drop n (foreignMem fptr (length l))     ]   where

@@ -51,10 +51,10 @@     [ testProperty "equal" $ withElementsM $ \fptr l ->         return $ toArrayP proxy l == foreignMem fptr (length l)     , testProperty "take" $ withElementsM $ \fptr l -> do-        n <- pick arbitrary+        n <- CountOf <$> pick arbitrary         return $ take n (toArrayP proxy l) == take n (foreignMem fptr (length l))     , testProperty "take" $ withElementsM $ \fptr l -> do-        n <- pick arbitrary+        n <- CountOf <$> pick arbitrary         return $ drop n (toArrayP proxy l) == drop n (foreignMem fptr (length l))     ]   where

@@ -93,7 +93,7 @@         revSplitAt n col == (revTake n col, revDrop n col)     ]   where-    withCollection2 f = forAll ((,) <$> (fromListP proxy <$> generateListOfElement genElement) <*> arbitrary) f+    withCollection2 f = forAll ((,) <$> (fromListP proxy <$> generateListOfElement genElement) <*> (CountOf <$> arbitrary)) f  testMonoid :: ( Show a, Show e               , Eq a, Eq e@@ -254,7 +254,7 @@     toListSecond (x,y) = (x, toList y)     withElements f = forAll (generateListOfElement genElement) f     with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f-    withElements2 f = forAll ((,) <$> generateListOfElement genElement <*> arbitrary) f-    withElements3 f = forAll ((,,) <$> generateListOfElement genElement <*> arbitrary <*> arbitrary) f+    withElements2 f = forAll ((,) <$> generateListOfElement genElement <*> (CountOf <$> arbitrary)) f+    withElements3 f = forAll ((,,) <$> generateListOfElement genElement <*> (CountOf <$> arbitrary) <*> (CountOf <$> arbitrary)) f     withElements2E f = forAll ((,) <$> generateListOfElement genElement <*> genElement) f     withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f