foundation 0.0.6 → 0.0.7

raw patch · 51 files changed

+1213/−743 lines, 51 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Foundation.hs +1/−1
• Foundation/Array/Bitmap.hs +67/−64
• Foundation/Array/Boxed.hs +113/−98
• Foundation/Array/Chunked/Unboxed.hs +112/−163
• Foundation/Array/Common.hs +17/−1
• Foundation/Array/Unboxed.hs +135/−121
• Foundation/Array/Unboxed/ByteArray.hs +12/−11
• Foundation/Array/Unboxed/Mutable.hs +23/−18
• Foundation/Boot/Builder.hs +1/−1
• Foundation/Check.hs +55/−15
• Foundation/Check/Arbitrary.hs +6/−0
• Foundation/Check/Property.hs +71/−11
• Foundation/Class/Storable.hs +1/−1
• Foundation/Collection/Buildable.hs +1/−1
• Foundation/Collection/Indexed.hs +15/−13
• Foundation/Collection/Mutable.hs +3/−3
• Foundation/Collection/Sequential.hs +9/−0
• Foundation/Foreign/MemoryMap/Posix.hsc +1/−1
• Foundation/Foreign/MemoryMap/Types.hs +1/−1
• Foundation/Foreign/MemoryMap/Windows.hs +1/−1
• Foundation/Hashing/FNV.hs +1/−1
• Foundation/Hashing/SipHash.hs +1/−1
• Foundation/IO/File.hs +6/−6
• Foundation/IO/FileMap.hs +1/−1
• Foundation/Internal/Environment.hs +1/−1
• Foundation/Internal/Natural.hs +5/−2
• Foundation/Internal/Types.hs +0/−117
• Foundation/Numerical/Subtractive.hs +4/−0
• Foundation/Primitive/Floating.hs +21/−0
• Foundation/Primitive/IntegralConv.hs +34/−3
• Foundation/Primitive/Types.hs +1/−1
• Foundation/Primitive/Types/OffsetSize.hs +142/−0
• Foundation/Primitive/Utils.hs +1/−1
• Foundation/Random.hs +1/−1
• Foundation/String/ASCII.hs +4/−3
• Foundation/String/Encoding/ASCII7.hs +1/−1
• Foundation/String/Encoding/Encoding.hs +1/−1
• Foundation/String/Encoding/ISO_8859_1.hs +1/−1
• Foundation/String/Encoding/UTF16.hs +1/−1
• Foundation/String/Encoding/UTF32.hs +1/−1
• Foundation/String/ModifiedUTF8.hs +1/−1
• Foundation/String/Read.hs +8/−0
• Foundation/String/UTF8.hs +246/−53
• Foundation/System/Entropy.hs +1/−1
• README.md +12/−0
• foundation.cabal +11/−3
• tests/Checks.hs +49/−5
• tests/Imports.hs +1/−0
• tests/Test/Foundation/Random.hs +1/−1
• tests/Test/Foundation/String.hs +0/−1
• tests/Tests.hs +10/−10

@@ -168,7 +168,7 @@ import           Foundation.Tuple  import qualified Foundation.Class.Bifunctor-import           Foundation.Internal.Types (Size(..), Offset(..))+import           Foundation.Primitive.Types.OffsetSize (Size(..), Offset(..)) import           Foundation.Internal.NumLiteral import           Foundation.Internal.Natural 

@@ -34,7 +34,7 @@ import           Foundation.Array.Unboxed.Mutable (MUArray) import           Foundation.Array.Common import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import qualified Foundation.Collection as C import           Foundation.Numerical@@ -43,9 +43,9 @@ import           GHC.ST import qualified Data.List -data Bitmap = Bitmap Int (UArray Word32)+data Bitmap = Bitmap (Size Bool) (UArray Word32) -data MutableBitmap st = MutableBitmap Int (MUArray Word32 st)+data MutableBitmap st = MutableBitmap (Size Bool) (MUArray Word32 st)  bitsPerTy :: Int bitsPerTy = 32@@ -110,22 +110,23 @@     find = find     sortBy = sortBy     singleton = fromList . (:[])+    replicate n = fromList . C.replicate n  instance C.IndexedCollection Bitmap where     (!) l n-        | n < 0 || n >= length l = Nothing-        | otherwise              = Just $ index l n+        | isOutOfBound n (lengthSize l) = Nothing+        | otherwise                     = Just $ index l n     findIndex predicate c = loop 0       where-        !len = length c+        !len = lengthSize c         loop i-            | i == len                    = Nothing+            | i .==# len                  = Nothing             | predicate (unsafeIndex c i) = Just i             | otherwise                   = Nothing  instance C.MutableCollection MutableBitmap where     type MutableFreezed MutableBitmap = Bitmap-    type MutableKey MutableBitmap = Int+    type MutableKey MutableBitmap = Offset Bool     type MutableValue MutableBitmap = Bool      thaw = thaw@@ -139,8 +140,8 @@     mutWrite = write     mutRead = read -bitmapIndex :: Offset Bool -> (Int, Int)-bitmapIndex (Offset !i) = (i .>>. shiftPerTy, i .&. maskPerTy)+bitmapIndex :: Offset Bool -> (Offset Word32, Int)+bitmapIndex (Offset !i) = (Offset (i .>>. shiftPerTy), i .&. maskPerTy) {-# INLINE bitmapIndex #-}  -- return the index in word32 quantity and mask to a bit in a bitmap@@ -195,52 +196,52 @@ unsafeFreeze :: PrimMonad prim => MutableBitmap (PrimState prim) -> prim Bitmap unsafeFreeze (MutableBitmap len mba) = Bitmap len `fmap` C.unsafeFreeze mba -unsafeWrite :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> Bool -> prim ()+unsafeWrite :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> Bool -> prim () unsafeWrite (MutableBitmap _ ma) i v = do-    let (idx, bitIdx) = bitmapIndex (Offset i)+    let (idx, bitIdx) = bitmapIndex i     w <- A.unsafeRead ma idx     let w' = if v then setBit w bitIdx else clearBit w bitIdx     A.unsafeWrite ma idx w' {-# INLINE unsafeWrite #-} -unsafeRead :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> prim Bool+unsafeRead :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> prim Bool unsafeRead (MutableBitmap _ ma) i = do-    let (idx, bitIdx) = bitmapIndex (Offset i)+    let (idx, bitIdx) = bitmapIndex i     flip testBit bitIdx `fmap` A.unsafeRead ma idx {-# INLINE unsafeRead #-} -write :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> Bool -> prim ()+write :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> Bool -> prim () write mb n val-    | n < 0 || n >= len = primThrow (OutOfBound OOB_Write n len)-    | otherwise         = unsafeWrite mb n val+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite mb n val   where-    len = mutableLength mb+    len = mutableLengthSize mb {-# INLINE write #-} -read :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> prim Bool+read :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> prim Bool read mb n-    | n < 0 || n >= len = primThrow (OutOfBound OOB_Read n len)-    | otherwise         = unsafeRead mb n-  where len = mutableLength mb+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise        = unsafeRead mb n+  where len = mutableLengthSize mb {-# INLINE read #-}  -- | Return the element at a specific index from a Bitmap. -- -- If the index @n is out of bounds, an error is raised.-index :: Bitmap -> Int -> Bool+index :: Bitmap -> Offset Bool -> Bool index bits n-    | n < 0 || n >= len = throw (OutOfBound OOB_Index n len)-    | otherwise         = unsafeIndex bits n-  where len = length bits+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex bits n+  where len = lengthSize bits {-# INLINE index #-}  -- | Return the element at a specific index from an array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values. -- use 'index' if unsure.-unsafeIndex :: Bitmap -> Int -> Bool+unsafeIndex :: Bitmap -> Offset Bool -> Bool unsafeIndex (Bitmap _ ba) n =-    let (idx, bitIdx) = bitmapIndex (Offset n)+    let (idx, bitIdx) = bitmapIndex n      in testBit (A.unsafeIndex ba idx) bitIdx  {-# INLINE unsafeIndex #-}@@ -249,17 +250,20 @@ -- higher level collection implementation ----------------------------------------------------------------------- length :: Bitmap -> Int-length (Bitmap len _) = len+length (Bitmap (Size len) _) = len -mutableLength :: MutableBitmap st -> Int-mutableLength (MutableBitmap len _) = len+lengthSize :: Bitmap -> Size Bool+lengthSize (Bitmap sz _) = sz +mutableLengthSize :: MutableBitmap st -> Size Bool+mutableLengthSize (MutableBitmap sz _) = sz+ empty :: Bitmap empty = Bitmap 0 A.empty  new :: PrimMonad prim => Size Bool -> prim (MutableBitmap (PrimState prim))-new (Size len) =-    MutableBitmap len <$> A.new nbElements+new sz@(Size len) =+    MutableBitmap sz <$> A.new nbElements   where     nbElements :: Size Word32     nbElements = Size ((len `alignRoundUp` bitsPerTy) .>>. shiftPerTy)@@ -290,15 +294,13 @@     toPacked l =         C.foldl (.|.) 0 $ Prelude.zipWith (\b w -> if b then (1 `shiftL` w) else 0) l (C.reverse [0..31]) -}--     len        = C.length allBools  -- | transform an array to a list. vToList :: Bitmap -> [Bool] vToList a = loop 0-  where len = length a-        loop i | i == len  = []+  where len = lengthSize a+        loop i | i .==# len  = []                | otherwise = unsafeIndex a i : loop (i+1)  -- | Check if two vectors are identical@@ -307,20 +309,20 @@     | la /= lb  = False     | otherwise = loop 0   where-    !la = length a-    !lb = length b-    loop n | n == la    = True+    !la = lengthSize a+    !lb = lengthSize b+    loop n | n .==# la = True            | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1)  -- | Compare 2 vectors vCompare :: Bitmap -> Bitmap -> Ordering vCompare a b = loop 0   where-    !la = length a-    !lb = length b+    !la = lengthSize a+    !lb = lengthSize b     loop n-        | n == la   = if la == lb then EQ else LT-        | n == lb   = GT+        | 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)@@ -340,13 +342,13 @@ null (Bitmap nbBits _) = nbBits == 0  take :: Int -> Bitmap -> Bitmap-take nbElems bits@(Bitmap nbBits ba)-    | nbElems <= 0     = empty+take nbElems bits@(Bitmap (Size nbBits) ba)+    | nbElems <= 0      = empty     | nbElems >= nbBits = bits-    | otherwise        = Bitmap nbElems ba -- TODO : although it work right now, take on the underlaying ba too+    | otherwise         = Bitmap (Size nbElems) ba -- TODO : although it work right now, take on the underlaying ba too  drop :: Int -> Bitmap -> Bitmap-drop nbElems bits@(Bitmap nbBits _)+drop nbElems bits@(Bitmap (Size nbBits) _)     | nbElems <= 0      = bits     | nbElems >= nbBits = empty     | otherwise         = unoptimised (C.drop nbElems) bits@@ -364,11 +366,12 @@ break :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) break predicate v = findBreak 0   where-    findBreak i-        | i == length v = (v, empty)-        | otherwise     =+    len = lengthSize v+    findBreak i@(Offset i')+        | i .==# len = (v, empty)+        | otherwise  =             if predicate (unsafeIndex v i)-                then splitAt i v+                then splitAt i' v                 else findBreak (i+1)  span :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap)@@ -400,10 +403,10 @@ find :: (Bool -> Bool) -> Bitmap -> Maybe Bool find predicate vec = loop 0   where-    !len = length vec+    !len = lengthSize vec     loop i-        | i == len  = Nothing-        | otherwise =+        | i .==# len = Nothing+        | otherwise  =             let e = unsafeIndex vec i              in if predicate e then Just e else loop (i+1) @@ -419,18 +422,18 @@ foldl :: (a -> Bool -> a) -> a -> Bitmap -> a foldl f initialAcc vec = loop 0 initialAcc   where-    len = length vec+    len = lengthSize vec     loop i acc-        | i == len  = acc-        | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))  foldr :: (Bool -> a -> a) -> a -> Bitmap -> a foldr f initialAcc vec = loop 0   where-    len = length vec+    len = lengthSize vec     loop i-        | i == len  = initialAcc-        | otherwise = unsafeIndex vec i `f` loop (i+1)+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)  foldr' :: (Bool -> a -> a) -> a -> Bitmap -> a foldr' = foldr@@ -438,10 +441,10 @@ foldl' :: (a -> Bool -> a) -> a -> Bitmap -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    len = length vec+    len = lengthSize vec     loop i !acc-        | i == len  = acc-        | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))  unoptimised :: ([Bool] -> [Bool]) -> Bitmap -> Bitmap unoptimised f = vFromList . f . vToList

@@ -10,11 +10,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-} module Foundation.Array.Boxed     ( Array     , MArray     , empty     , length+    , lengthSize+    , mutableLength+    , mutableLengthSize     , copy     , copyAt     , unsafeCopyAtRO@@ -30,6 +34,7 @@     , read     , index     , singleton+    , replicate     , null     , take     , drop@@ -63,9 +68,11 @@ import           GHC.ST import           Foundation.Numerical import           Foundation.Internal.Base+import           Foundation.Internal.Proxy import           Foundation.Internal.MonadTrans-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Types+import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Monad import           Foundation.Array.Common import           Foundation.Boot.Builder@@ -118,59 +125,64 @@ mutableLength (MArray _ (Size len) _) = len {-# INLINE mutableLength #-} +-- | return the numbers of elements in a mutable array+mutableLengthSize :: MArray ty st -> Size ty+mutableLengthSize (MArray _ size _) = size+{-# INLINE mutableLengthSize #-}+ -- | Return the element at a specific index from an array. -- -- If the index @n is out of bounds, an error is raised.-index :: Array ty -> Int -> ty+index :: Array ty -> Offset ty -> ty index array n-    | n < 0 || n >= len = throw (OutOfBound OOB_Index n len)-    | otherwise         = unsafeIndex array n-  where len = length array+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where len = lengthSize array {-# INLINE index #-}  -- | Return the element at a specific index from an array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values. -- use 'index' if unsure.-unsafeIndex :: Array ty -> Int -> ty-unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+Offset ofs)+unsafeIndex :: Array ty -> Offset ty -> ty+unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+ofs) {-# INLINE unsafeIndex #-}  -- | read a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.-read :: PrimMonad prim => MArray ty (PrimState prim) -> Int -> prim ty+read :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty read array n-    | n < 0 || n >= len = primThrow (OutOfBound OOB_Read n len)-    | otherwise         = unsafeRead array n-  where len = mutableLength array+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise          = unsafeRead array n+  where len = mutableLengthSize array {-# INLINE read #-}  -- | read from a cell in a mutable array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values. -- use 'read' if unsure.-unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Int -> prim ty-unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + Offset i)+unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + i) {-# INLINE unsafeRead #-}  -- | Write to a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.-write :: PrimMonad prim => MArray ty (PrimState prim) -> Int -> ty -> prim ()+write :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim () write array n val-    | n < 0 || n >= len = primThrow (OutOfBound OOB_Write n len)-    | otherwise         = unsafeWrite array n val-  where len = mutableLength array+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite array n val+  where len = mutableLengthSize array {-# INLINE write #-}  -- | write to a cell in a mutable array without bounds checking. -- -- Writing with invalid bounds will corrupt memory and your program will -- become unreliable. use 'write' if unsure.-unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Int -> ty -> prim ()+unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> ty -> prim () unsafeWrite (MArray start _ ma) ofs v =-    primMutableArrayWrite ma (start + Offset ofs) v+    primMutableArrayWrite ma (start + ofs) v {-# INLINE unsafeWrite #-}  -- | Freeze a mutable array into an array.@@ -206,7 +218,7 @@     copyAt m (Offset 0) marray (Offset 0) sz     unsafeFreeze m   where-    sz = Size $ mutableLength marray+    sz = mutableLengthSize marray  -- | Copy the element to a new element array copy :: Array ty -> Array ty@@ -221,10 +233,10 @@        -> Size ty                    -- ^ number of elements to copy        -> prim () copyAt dst od src os n = loop od os-  where !endIndex = os `offsetPlusE` n-        loop (Offset d) s@(Offset i)-            | s == endIndex = return ()-            | otherwise     = unsafeRead src i >>= unsafeWrite dst d >> loop (Offset $ d+1) (Offset $ i+1)+  where -- !endIndex = os `offsetPlusE` n+        loop d s+            | s .==# n  = pure ()+            | otherwise = unsafeRead src s >>= unsafeWrite dst d >> loop (d+1) (s+1)  -- | Copy @n@ sequential elements from the specified offset in a source array --   to the specified position in a destination array.@@ -272,18 +284,17 @@  -- | Create a new array of size @n by settings each cells through the -- function @f.-create :: Int         -- ^ the size of the array-       -> (Int -> ty) -- ^ the function that set the value at the index-       -> Array ty   -- ^ the array created-create n initializer = runST (new (Size n) >>= iter initializer)+create :: forall ty . Size 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)   where-    iter :: PrimMonad prim => (Int -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)-    iter f ma = loop (Offset 0)+    iter :: PrimMonad prim => (Offset ty -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)+    iter f ma = loop 0       where-        !end = Offset 0 `offsetPlusE` Size n-        loop s@(Offset i)-            | s == end  = unsafeFreeze ma-            | otherwise = unsafeWrite ma i (f i) >> loop (Offset $ i+1)+        loop s+            | s .==# n  = unsafeFreeze ma+            | otherwise = unsafeWrite ma s (f s) >> loop (s+1)         {-# INLINE loop #-}     {-# INLINE iter #-} @@ -291,22 +302,22 @@ -- higher level collection implementation ----------------------------------------------------------------------- equal :: Eq a => Array a -> Array a -> Bool-equal a b = (len == length b) && eachEqual 0+equal a b = (len == lengthSize b) && eachEqual 0   where-    len = length a+    len = lengthSize a     eachEqual !i-        | i == len                           = True+        | i .==# len                         = True         | unsafeIndex a i /= unsafeIndex b i = False         | otherwise                          = eachEqual (i+1)  vCompare :: Ord a => Array a -> Array a -> Ordering vCompare a b = loop 0   where-    !la = length a-    !lb = length b+    !la = lengthSize a+    !lb = lengthSize b     loop n-        | n == la   = if la == lb then EQ else LT-        | n == lb   = GT+        | 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)@@ -329,16 +340,17 @@     loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma  vToList :: Array a -> [a]-vToList v = fmap (unsafeIndex v) [0..(length v - 1)]+vToList v+    | len == 0  = []+    | otherwise = fmap (unsafeIndex v) [0..sizeLastOffset len]+  where !len = lengthSize v  -- | Append 2 arrays together by creating a new bigger array append :: Array ty -> Array ty -> Array ty append a b = runST $ do     r  <- new (la+lb)-    ma <- unsafeThaw a-    mb <- unsafeThaw b-    copyAt r (Offset 0) ma (Offset 0) la-    copyAt r (sizeAsOffset la) mb (Offset 0) lb+    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@@ -350,8 +362,7 @@     unsafeFreeze r   where loop _ _ []     = return ()         loop r i (x:xs) = do-            mx <- unsafeThaw x-            copyAt r i mx (Offset 0) lx+            unsafeCopyAtRO r i x (Offset 0) lx             loop r (i `offsetPlusE` lx) xs           where lx = lengthSize x @@ -430,11 +441,11 @@   where     !len = lengthSize vec     !endIdx = Offset 0 `offsetPlusE` len-    loop prevIdx idx@(Offset i)+    loop prevIdx idx         | idx == endIdx = [sub vec prevIdx idx]         | otherwise     =-            let e = unsafeIndex vec i-                idx' = idx + Offset 1+            let e = unsafeIndex vec idx+                idx' = idx + 1              in if predicate e                     then sub vec prevIdx idx : loop idx' idx'                     else loop prevIdx idx'@@ -450,11 +461,12 @@ break ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty) break predicate v = findBreak 0   where-    findBreak i-        | i == length v = (v, empty)-        | otherwise     =+    !len = lengthSize v+    findBreak i@(Offset i')+        | i .==# len  = (v, empty)+        | otherwise   =             if predicate (unsafeIndex v i)-                then splitAt i v+                then splitAt i' v                 else findBreak (i+1)  intersperse :: ty -> Array ty -> Array ty@@ -465,20 +477,20 @@         -- terminate 1 before the end          go :: Offset ty -> ty -> Array ty -> Offset ty -> MArray ty s -> ST s ()-        go endI sep' oldV oldI@(Offset oi) newV+        go endI sep' oldV oldI newV             | oldI == endI = unsafeWrite newV dst e             | otherwise    = do                 unsafeWrite newV dst e                 unsafeWrite newV (dst + 1) sep'           where-            e = unsafeIndex oldV oi-            (Offset dst) = oldI + oldI+            e = unsafeIndex oldV oldI+            dst = oldI + oldI  span ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty) span p = break (not . p)  map :: (a -> b) -> Array a -> Array b-map f a = create (length a) (\i -> f $ unsafeIndex a i)+map f a = create (sizeCast Proxy $ lengthSize a) (\i -> f $ unsafeIndex a (offsetCast Proxy i))  {- mapIndex :: (Int -> a -> b) -> Array a -> Array b@@ -491,6 +503,9 @@     unsafeWrite a 0 e     unsafeFreeze a +replicate :: Word -> ty -> Array ty+replicate sz ty = create (Size (integralCast sz)) (const ty)+ cons :: ty -> Array ty -> Array ty cons e vec     | len == Size 0 = singleton e@@ -504,14 +519,14 @@  snoc ::  Array ty -> ty -> Array ty snoc vec e-    | len == Size 0 = singleton e-    | otherwise     = runST $ do-        mv <- new (len + Size 1)-        unsafeCopyAtRO mv (Offset 0) vec (Offset 0) len-        unsafeWrite mv lastI e+    | len == 0  = singleton e+    | otherwise = runST $ do+        mv <- new (len + 1)+        unsafeCopyAtRO mv 0 vec 0 len+        unsafeWrite mv (sizeAsOffset len) e         unsafeFreeze mv   where-    !len@(Size lastI) = lengthSize vec+    !len = lengthSize vec  uncons :: Array ty -> Maybe (ty, Array ty) uncons vec@@ -523,32 +538,34 @@ unsnoc :: Array ty -> Maybe (Array ty, ty) unsnoc vec     | len == 0  = Nothing-    | otherwise = Just (take (len - 1) vec, unsafeIndex vec (len-1))+    | otherwise = Just (take (lenI - 1) vec, unsafeIndex vec (sizeLastOffset len))   where-    !len = length vec+    !len@(Size lenI) = lengthSize vec  find ::  (ty -> Bool) -> Array ty -> Maybe ty find predicate vec = loop 0   where-    !len = length vec+    !len = lengthSize vec     loop i-        | i == len  = Nothing-        | otherwise =+        | i .==# len = Nothing+        | otherwise  =             let e = unsafeIndex vec i              in if predicate e then Just e else loop (i+1) -sortBy ::  (ty -> ty -> Ordering) -> Array ty -> Array ty-sortBy xford vec = runST (thaw vec >>= doSort xford)+sortBy :: forall ty . (ty -> ty -> Ordering) -> Array ty -> Array ty+sortBy xford vec+    | len == 0  = empty+    | otherwise = runST (thaw vec >>= doSort xford)   where-    len = length vec+    len = lengthSize vec     doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty)-    doSort ford ma = qsort 0 (len - 1) >> unsafeFreeze ma+    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma       where         qsort lo hi             | lo >= hi  = return ()             | otherwise = do                 p <- partition lo hi-                qsort lo (p-1)+                qsort lo (pred p)                 qsort (p+1) hi         partition lo hi = do             pivot <- unsafeRead ma hi@@ -572,20 +589,19 @@             unsafeWrite ma i ahi             return i -filter :: (ty -> Bool) -> Array ty -> Array ty+filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec))   where     !len = lengthSize vec-    !end = Offset 0 `offsetPlusE` len-    copyFilterFreeze :: PrimMonad prim => (ty -> Bool) -> (Int -> ty) -> MArray ty (PrimState prim) -> prim (Array ty)+    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-        loop d@(Offset di) s@(Offset si)-            | s == end    = return d-            | predi v     = unsafeWrite mvec di v >> loop (d+Offset 1) (s+Offset 1)-            | otherwise   = loop d (s+Offset 1)+        loop d s+            | s .==# len  = return d+            | predi v     = unsafeWrite mvec d v >> loop (d+1) (s+1)+            | otherwise   = loop d (s+1)           where-            v = getVec si+            v = getVec s  freezeUntilIndex :: PrimMonad prim => MArray ty (PrimState prim) -> Offset ty -> prim (Array ty) freezeUntilIndex mvec d = do@@ -599,36 +615,36 @@ reverse :: Array ty -> Array ty reverse a = create len toEnd   where-    len = length a-    toEnd i = unsafeIndex a (len - i - 1)+    len@(Size s) = lengthSize 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 = length vec+    len = lengthSize vec     loop !i acc-        | i == len  = acc-        | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))  foldr :: (ty -> a -> a) -> a -> Array ty -> a foldr f initialAcc vec = loop 0   where-    len = length vec+    len = lengthSize vec     loop !i-        | i == len  = initialAcc-        | otherwise = unsafeIndex vec i `f` loop (i+1)+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)  foldl' :: (a -> ty -> a) -> a -> Array ty -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    len = length vec+    len = lengthSize vec     loop !i !acc-        | i == len  = acc-        | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))  builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state () builderAppend v = Builder $ State $ \(i, st) ->-    if offsetAsSize i == chunkSize st+    if i .==# chunkSize st         then do             cur      <- unsafeFreeze (curChunk st)             newChunk <- new (chunkSize st)@@ -638,9 +654,8 @@                                       , curChunk       = newChunk                                       }))         else do-            let (Offset i') = i-            unsafeWrite (curChunk st) i' v-            return ((), (i + Offset 1, st))+            unsafeWrite (curChunk st) i v+            return ((), (i+1, st))  builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () -> m (Array ty) builderBuild sizeChunksI ab

@@ -1,7 +1,6 @@ -- | -- Module      : Foundation.Array.Chunked.Unboxed--- License     : BSD-style--- Maintainer  : Alfredo Di Napoli <alfredo.dinapoli@gmail.com>+-- License     : BSD-style -- Maintainer  : Alfredo Di Napoli <alfredo.dinapoli@gmail.com> -- Stability   : experimental -- Portability : portable --@@ -19,6 +18,7 @@  import qualified Data.List import           Data.Typeable+import           Control.Arrow ((***)) import           Foundation.Array.Boxed (Array) import qualified Foundation.Array.Boxed as A import           Foundation.Array.Common@@ -27,15 +27,13 @@ import           Foundation.Class.Bifunctor import qualified Foundation.Collection as C import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Numerical-import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           GHC.ST-import qualified Prelude as P  -data ChunkedUArray ty = ChunkedUArray (Array (UArray ty))+newtype ChunkedUArray ty = ChunkedUArray (Array (UArray ty))                       deriving (Show, Ord, Typeable)  instance PrimType ty => Eq (ChunkedUArray ty) where@@ -65,6 +63,7 @@ instance PrimType ty => C.Sequential (ChunkedUArray ty) where     take = take     drop = drop+    splitAt = splitAt     revTake = revTake     revDrop = revDrop     splitOn = splitOn@@ -79,70 +78,64 @@     find = find     sortBy = sortBy     singleton = fromList . (:[])+    replicate n = fromList . C.replicate n  instance PrimType ty => C.IndexedCollection (ChunkedUArray ty) where     (!) l n-        | n < 0 || n >= length l = Nothing-        | otherwise              = Just $ index l n+        | isOutOfBound n (lengthSize l) = Nothing+        | otherwise                     = Just $ index l n     findIndex predicate c = loop 0       where-        !len = length c+        !len = lengthSize c         loop i-            | i == len  = Nothing-            | otherwise =+            | i .==# len = Nothing+            | otherwise  =                 if predicate (unsafeIndex c i) then Just i else Nothing  empty :: ChunkedUArray ty empty = ChunkedUArray (A.empty)  append :: ChunkedUArray ty -> ChunkedUArray ty -> ChunkedUArray ty-append (ChunkedUArray a1) (ChunkedUArray a2) = ChunkedUArray $ runST $ do-  let a1Size@(Size a1len) = Size $ C.length a1-  let a2Size              = Size $ C.length a2-  a <- A.new (a1Size + a2Size)-  A.thaw a1 >>= \a1' -> A.copyAt a (Offset 0) a1' (Offset 0) a1Size-  A.thaw a2 >>= \a2' -> A.copyAt a (Offset a1len) a2' (Offset 0) a2Size-  A.unsafeFreeze a+append (ChunkedUArray a1) (ChunkedUArray a2) = ChunkedUArray (mappend a1 a2)  concat :: [ChunkedUArray ty] -> ChunkedUArray ty-concat x = C.foldl' append mempty x+concat x = ChunkedUArray (mconcat $ fmap (\(ChunkedUArray spine) -> spine) x)  vFromList :: PrimType ty => [ty] -> ChunkedUArray ty-vFromList l = ChunkedUArray array-  where-    array = runST $ do-      a <- A.new (Size 1)-      A.unsafeWrite a 0 (fromList l)-      A.unsafeFreeze a+vFromList l = ChunkedUArray $ A.singleton $ fromList l  vToList :: PrimType ty => ChunkedUArray ty -> [ty] vToList (ChunkedUArray a) = mconcat $ toList $ toList <$> a  null :: PrimType ty => ChunkedUArray ty -> Bool null (ChunkedUArray array) =-  let len = C.length array-  in C.null array || allNulls 0 len+    C.null array || allNulls 0   where-    allNulls !idx len-      | idx == len = True-      | otherwise  = C.null (array `A.unsafeIndex` idx) && allNulls (idx + 1) len+    !len = A.lengthSize 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+ -- | 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 array = go 0+elem el (ChunkedUArray array) = loop 0   where-    len = C.length array-    go !currentIndex = case currentIndex < len of-      True  -> case el == array `unsafeIndex` currentIndex of-        True  -> True-        False -> go (currentIndex + 1)-      False -> False+    !len = A.lengthSize array+    loop i+        | i .==# len = False+        | otherwise  =+            case C.elem el (A.unsafeIndex array i) of+                True  -> True+                False -> loop (i+1)  -- | TODO: Improve implementation. minimum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty@@ -157,128 +150,75 @@ -- equality the inner `UArray`(s), we need an element-by-element -- comparison. equal :: PrimType ty => ChunkedUArray ty -> ChunkedUArray ty -> Bool-equal ca1 ca2 = len1 == len2 && deepEqual+equal ca1 ca2 =+    len1 == len2 && go 0   where-    len1 = C.length ca1-    len2 = C.length ca2+    len1 = lengthSize ca1+    len2 = lengthSize ca2 -    deepEqual :: Bool-    deepEqual = go 0 0+    go !x+      | x .==# len1 = True+      | otherwise   = (ca1 `unsafeIndex` x == ca2 `unsafeIndex` x) && go (x + 1) -    go !x !y-      | x == len1 && y == len2 = True-      | otherwise =-        (ca1 `unsafeIndex` x == ca2 `unsafeIndex` y) && go (x + 1) (y + 1)+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+    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+             in case removeArraySize relOfs innerLen of+                        Nothing      -> Just (outerI, relOfs)+                        Just relOfs' -> loop relOfs' (outerI + 1) --- | Take the first n elements from this `ChunkedUArray`.--- TODO: Perform compaction? Compacting the underlying chunks will have--- the snag of copying data, but the pro of improving cache-friendliness--- and reduce data scattering.+splitChunk :: Offset (UArray ty) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty)+splitChunk (Offset ofs) (ChunkedUArray c) = (ChunkedUArray *** ChunkedUArray) $ A.splitAt ofs c+ take :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty-take nbElems v@(ChunkedUArray inner)-    | nbElems <= 0 = empty-    | C.null v     = empty-    | nbElems >= C.length v = v+take n c@(ChunkedUArray spine)+    | n <= 0    = empty     | otherwise =-      let newSize = Size requiredChunks-      in ChunkedUArray $ runST (A.new newSize >>= iter inner nbElems)-  where-    -- TODO: How can we avoid this first pass?-    requiredChunks = loop 0 nbElems-      where-        loop !idx !remaining-          | remaining <= 0 = idx-          | otherwise =-            let vec = inner `A.unsafeIndex` idx-                l = U.length vec-            in loop (idx + 1) (remaining - l)-    iter :: (PrimType ty, PrimMonad prim)-         => Array (UArray ty)-         -> Int-         -> A.MArray (UArray ty) (PrimState prim)-         -> prim (Array (UArray ty))-    iter inner0 elems finalVector = loop 0 elems-      where-        loop !currentIndex !remainingElems-          | remainingElems <= 0 || currentIndex >= C.length inner0 = A.unsafeFreeze finalVector-          | otherwise =-            let chunk = inner0 `A.unsafeIndex` currentIndex -- TODO: skip empty chunks-                chunkLen = C.length chunk-            in case C.null chunk of-              True -> loop (currentIndex + 1) remainingElems-              False -> case chunkLen <= remainingElems of-                True -> do-                  A.unsafeWrite finalVector currentIndex chunk-                  loop (currentIndex + 1) (remainingElems - chunkLen)-                False -> do-                  nc <- do-                    newChunk <- U.new (Size remainingElems)-                    U.unsafeCopyAtRO newChunk (Offset 0) chunk (Offset 0) (Size remainingElems)-                    U.unsafeFreeze newChunk-                  A.unsafeWrite finalVector currentIndex nc-                  A.freeze finalVector+        case findPos (Offset n) c of+            Nothing              -> c+            Just (Offset ofs, 0) -> ChunkedUArray (A.take ofs spine)+            Just (ofs@(Offset ofs'), (Offset r)) ->+                let uarr = A.unsafeIndex spine ofs+                 in ChunkedUArray (A.take ofs' spine `A.snoc` U.take r uarr)  drop :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty-drop nbElems v@(ChunkedUArray inner)-    | nbElems >= C.length v = empty-    | nbElems <= 0 = v-    | C.null v     = empty+drop n c@(ChunkedUArray spine)+    | n <= 0    = c     | otherwise =-      let newSize = Size (C.length inner - chunksToSkip)-      in ChunkedUArray $ runST (A.new newSize >>= iter inner nbElems)-  where-    -- TODO: How can we avoid this first pass?-    chunksToSkip = loop 0 nbElems-      where-        loop !idx !remaining =-          let vec   = inner `A.unsafeIndex` idx-              l     = U.length vec-              slack = remaining - l-          in case slack of-            x | x == 0 -> idx + 1-            x | x <  0 -> idx-            _          -> loop (idx + 1) slack-    iter :: (PrimType ty, PrimMonad prim)-         => Array (UArray ty)-         -> Int-         -> A.MArray (UArray ty) (PrimState prim)-         -> prim (Array (UArray ty))-    iter inner0 elems finalVector = loop 0 elems-      where-        -- We do not skip empty chunks, or this would screw-        -- the total, final size.-        loop !currentIndex !remainingElems-          | remainingElems <= 0 = do-            -- Copy the rest of the vector-            A.unsafeCopyAtRO finalVector (Offset 0) inner0 (Offset currentIndex) (Size $ C.length inner0 - currentIndex)-            A.freeze finalVector-          | otherwise =-            let chunk = inner0 `A.unsafeIndex` currentIndex-                chunkLen = C.length chunk-                slack    = chunkLen P.- remainingElems-            in case chunkLen <= remainingElems of-                True -> do-                  -- Skip the whole chunk-                  loop (currentIndex + 1) (remainingElems - chunkLen)-                False -> do-                  nc <- do-                    newChunk <- U.new (Size slack)-                    U.unsafeCopyAtRO newChunk (Offset 0) chunk (Offset remainingElems) (Size slack)-                    U.unsafeFreeze newChunk-                  A.unsafeWrite finalVector 0 nc-                  -- Copy the rest of the vector-                  let !nextIdx = currentIndex + 1-                  A.unsafeCopyAtRO finalVector (Offset 1) inner0 (Offset nextIdx) (Size $ C.length inner0 - nextIdx)-                  A.freeze finalVector+        case findPos (Offset n) c of+            Nothing              -> empty+            Just (Offset ofs, 0) -> ChunkedUArray (A.drop ofs spine)+            Just (ofs@(Offset ofs'), (Offset r)) ->+                let uarr = A.unsafeIndex spine ofs+                 in ChunkedUArray (U.drop r uarr `A.cons` A.drop (ofs'+1) spine) +splitAt :: PrimType ty => Int -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty)+splitAt n c@(ChunkedUArray spine)+    | n <= 0    = (empty, c)+    | otherwise =+        case findPos (Offset n) c of+            Nothing       -> (c, empty)+            Just (ofs, 0) -> splitChunk ofs c+            Just (ofs@(Offset ofs'), (Offset 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)+                    ) --- TODO: Improve implementation. revTake :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty-revTake x = fromList . C.revTake x . toList+revTake n c = drop (length c - n) c --- TODO: Improve implementation. revDrop :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty-revDrop x = fromList . C.revDrop x . toList+revDrop n c = take (length c - n) c  -- TODO: Improve implementation. splitOn :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> [ChunkedUArray ty]@@ -318,36 +258,38 @@   A.unsafeFreeze newArray  snoc :: PrimType ty => ChunkedUArray ty -> ty -> ChunkedUArray ty-snoc (ChunkedUArray inner) el = ChunkedUArray $ runST $ do-  newArray   <- A.new (Size $ C.length inner + 1)-  let single = fromList [el]-  A.unsafeCopyAtRO newArray (Offset 0) inner (Offset 0) (Size $ C.length inner)-  A.unsafeWrite newArray (C.length inner) single+snoc (ChunkedUArray spine) el = ChunkedUArray $ runST $ do+  newArray  <- A.new (A.lengthSize 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.unsafeFreeze newArray +-- TODO optimise find :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> Maybe ty-find fn v = loop 0 (C.length v)+find fn v = loop 0   where-    loop !idx len-      | idx >= len = Nothing-      | otherwise  =+    len = lengthSize v+    loop !idx+      | idx .==# len = Nothing+      | otherwise    =         let currentElem = v `unsafeIndex` idx         in case fn currentElem of           True  -> Just currentElem-          False -> loop (idx + 1) len+          False -> loop (idx + 1)  -- TODO: Improve implementation. sortBy :: PrimType ty => (ty -> ty -> Ordering) -> ChunkedUArray ty -> ChunkedUArray ty sortBy p = fromList . C.sortBy p . toList -index :: PrimType ty => ChunkedUArray ty -> Int -> ty+index :: PrimType ty => ChunkedUArray ty -> Offset ty -> ty index array n-    | n < 0 || n >= len = throw (OutOfBound OOB_Index n len)-    | otherwise         = unsafeIndex array n-  where len = C.length array+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where len = lengthSize array {-# INLINE index #-} -unsafeIndex :: PrimType ty => ChunkedUArray ty -> Int -> ty+unsafeIndex :: PrimType ty => ChunkedUArray ty -> Offset ty -> ty unsafeIndex (ChunkedUArray array) idx = go (A.unsafeIndex array 0) 0 idx   where     go u globalIndex 0 = case C.null u of@@ -357,7 +299,14 @@     go u !globalIndex !i       -- Skip empty chunks.       | C.null u  = go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i-      | otherwise = case i - (C.length u) of-        i' | i' >= 0 -> go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i'-        _            -> U.unsafeIndex u i+      | otherwise =+          case removeArraySize i (U.lengthSize 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)+    | ty >= s   = Just (Offset (ty - s))+    | otherwise = Nothing

@@ -11,13 +11,17 @@ module Foundation.Array.Common     ( OutOfBound(..)     , OutOfBoundOperation(..)-+    , isOutOfBound+    , outOfBound+    , primOutOfBound     , InvalidRecast(..)     , RecastSourceSize(..)     , RecastDestinationSize(..)     ) where  import           Foundation.Internal.Base+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad  -- | The type of operation that triggers an OutOfBound exception. --@@ -34,6 +38,18 @@     deriving (Show,Typeable)  instance Exception OutOfBound++outOfBound :: OutOfBoundOperation -> Offset ty -> Size ty -> a+outOfBound oobop (Offset ofs) (Size 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)+{-# INLINE primOutOfBound #-}++isOutOfBound :: Offset ty -> Size ty -> Bool+isOutOfBound (Offset ty) (Size sz) = ty < 0 || ty >= sz+{-# INLINE isOutOfBound #-}  newtype RecastSourceSize      = RecastSourceSize Int     deriving (Show,Eq,Typeable)

@@ -13,6 +13,8 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-} module Foundation.Array.Unboxed     ( UArray(..)     , PrimType(..)@@ -49,6 +51,8 @@     , unsafeRead     , unsafeWrite     -- * Functions+    , singleton+    , replicate     , map     , mapIndex     , findIndex@@ -95,11 +99,12 @@ import           Foundation.Internal.Base import           Foundation.Internal.Primitive import           Foundation.Internal.Proxy-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Internal.MonadTrans import qualified Foundation.Primitive.Base16 as Base16 import           Foundation.Primitive.Monad import           Foundation.Primitive.Types+import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.Utils import           Foundation.Array.Common@@ -169,33 +174,27 @@ -- | Return the element at a specific index from an array. -- -- If the index @n is out of bounds, an error is raised.-index :: PrimType ty => UArray ty -> Int -> ty+index :: PrimType ty => UArray ty -> Offset ty -> ty index array n-    | n < 0 || n >= len = throw (OutOfBound OOB_Index n len)-    | otherwise         = unsafeIndex array n-  where len = length array+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where+    !len = lengthSize array {-# INLINE index #-}  -- | Return the element at a specific index from an array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values. -- use 'index' if unsure.-unsafeIndex :: PrimType ty => UArray ty -> Int -> ty-unsafeIndex (UVecBA start _ _ ba) n = primBaIndex ba (start + Offset n)-unsafeIndex v@(UVecAddr start _ fptr) n = withUnsafeFinalPtr fptr (primAddrIndex' v start)-  where-    primAddrIndex' :: PrimType ty => UArray ty -> Offset ty -> Ptr a -> IO ty-    primAddrIndex' _ start' (Ptr addr) = return (primAddrIndex addr (start' + Offset n))+unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty+unsafeIndex (UVecBA start _ _ ba) n = primBaIndex ba (start + n)+unsafeIndex (UVecAddr start _ fptr) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty) {-# INLINE unsafeIndex #-}  unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a unsafeIndexer (UVecBA start _ _ ba) f = f (\n -> primBaIndex ba (start + n))-unsafeIndexer (UVecAddr start _ fptr) f = withFinalPtr fptr (\ptr -> f (primAddrIndex' start ptr))-  where-    primAddrIndex' :: PrimType ty => Offset ty -> Ptr a -> (Offset ty -> ty)-    primAddrIndex' start' (Ptr addr) = \n -> primAddrIndex addr (start' + n)-    {-# INLINE primAddrIndex' #-}-{-# NOINLINE unsafeIndexer #-}+unsafeIndexer (UVecAddr start _ fptr) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n))+{-# INLINE unsafeIndexer #-}  unsafeDewrap :: PrimType ty              => (ByteArray# -> Offset ty -> a)@@ -258,25 +257,25 @@     !(Size (I# nBytes)) = sizeOfE sz n unsafeCopyAtRO dst od src os n = loop od os   where-    !(Offset endIndex) = os `offsetPlusE` n-    loop (Offset d) (Offset i)+    !endIndex = os `offsetPlusE` n+    loop d i         | i == endIndex = return ()-        | otherwise     = unsafeWrite dst d (unsafeIndex src i) >> loop (Offset $ d+1) (Offset $ i+1)+        | otherwise     = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1)  -- | Allocate a new array with a fill function that has access to the elements of --   the source array.-unsafeCopyFrom :: PrimType ty-               => UArray ty -- ^ Source array-               -> Int -- ^ Length of the destination array-               -> (UArray ty -> Int -> MUArray ty s -> ST s ())+unsafeCopyFrom :: (PrimType a, PrimType b)+               => UArray a -- ^ Source array+               -> Size 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 ty) -- ^ Returns the filled new array-unsafeCopyFrom v' newLen f = new (Size newLen) >>= fill 0 f >>= unsafeFreeze-  where len = length v'-        fill i f' r'-            | i == len  = return r'-            | otherwise = do f' v' i r'-                             fill (i + 1) f' r'+               -> ST s (UArray b) -- ^ Returns the filled new array+unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze+  where len = lengthSize v'+        fill i r'+            | i .==# len = return r'+            | otherwise  = do f v' i r'+                              fill (i + 1) r'  -- | Freeze a mutable array into an array. --@@ -300,14 +299,14 @@     unsafeFreeze ma'   where len = Size $ mutableLength ma -freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Int -> prim (UArray ty)+freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Size ty -> prim (UArray ty) freezeShrink ma n = do-    ma' <- new (Size n)-    copyAt ma' (Offset 0) ma (Offset 0) (Size n)+    ma' <- new n+    copyAt ma' (Offset 0) ma (Offset 0) n     unsafeFreeze ma' -unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Int -> Int -> prim ()-unsafeSlide mua s e = doSlide mua (Offset s) (Offset e)+unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()+unsafeSlide mua s e = doSlide mua s e   where     doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()     doSlide (MUVecMA mbStart _ _ mba) start end  =@@ -325,19 +324,19 @@  -- | Create a new array of size @n by settings each cells through the -- function @f.-create :: PrimType ty-       => Int         -- ^ the size of the array-       -> (Int -> ty) -- ^ the function that set the value at the index-       -> UArray ty  -- ^ the array created+create :: forall ty . PrimType ty+       => Size 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     | n == 0    = empty-    | otherwise = runST (new (Size n) >>= iter initializer)+    | otherwise = runST (new n >>= iter initializer)   where-    iter :: (PrimType ty, PrimMonad prim) => (Int -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty)+    iter :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty)     iter f ma = loop 0       where         loop i-            | i == n    = unsafeFreeze ma+            | i .==# n  = unsafeFreeze ma             | otherwise = unsafeWrite ma i (f i) >> loop (i+1)         {-# INLINE loop #-}     {-# INLINE iter #-}@@ -365,8 +364,11 @@ empty = UVecAddr (Offset 0) (Size 0) (FinalPtr $ error "empty de-referenced")  singleton :: PrimType ty => ty -> UArray ty-singleton ty = create 1 (\_ -> ty)+singleton ty = create 1 (const ty) +replicate :: PrimType ty => Word -> ty -> UArray ty+replicate sz ty = create (Size (integralCast sz)) (const ty)+ -- | make an array from a list of elements. vFromList :: PrimType ty => [ty] -> UArray ty vFromList l = runST $ do@@ -374,22 +376,26 @@     iter 0 l $ \i x -> unsafeWrite ma i x     unsafeFreeze ma   where len = Data.List.length l-        iter _ [] _ = return ()-        iter i (x:xs) z = z i x >> iter (i+1) xs z+        iter _  []     _ = return ()+        iter !i (x:xs) z = z i x >> iter (i+1) xs z  -- | transform an array to a list.-vToList :: PrimType ty => UArray ty -> [ty]+vToList :: forall ty . PrimType ty => UArray ty -> [ty] vToList a-    | null a    = []-    | otherwise = runST (unsafeIndexer a go)+    | len == 0  = []+    | otherwise = unsafeDewrap goBa goPtr a   where-    !len = length a-    go :: (Offset ty -> ty) -> ST s [ty]-    go getIdx = return $ loop azero+    !len = lengthSize a+    goBa ba start = loop start       where-        loop i | i == Offset len = []-               | otherwise        = getIdx i : loop (i+Offset 1)-    {-# INLINE go #-}+        !end = start `offsetPlusE` len+        loop !i | i == end  = []+                | otherwise = primBaIndex ba i : loop (i+1)+    goPtr (Ptr addr) start = pureST (loop start)+      where+        !end = start `offsetPlusE` len+        loop !i | i == end  = []+                | otherwise = primAddrIndex addr i : loop (i+1)  -- | Check if two vectors are identical equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool@@ -397,9 +403,9 @@     | la /= lb  = False     | otherwise = loop 0   where-    !la = length a-    !lb = length b-    loop n | n == la    = True+    !la = lengthSize a+    !lb = lengthSize b+    loop n | n .==# la = True            | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1)  {-@@ -411,11 +417,11 @@ vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering vCompare a b = loop 0   where-    !la = length a-    !lb = length b+    !la = lengthSize a+    !lb = lengthSize b     loop n-        | n == la   = if la == lb then EQ else LT-        | n == lb   = GT+        | 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)@@ -466,7 +472,7 @@ -- the operation copy the previous array, modify it in place, then freeze it. update :: PrimType ty        => UArray ty-       -> [(Int, ty)]+       -> [(Offset ty, ty)]        -> UArray ty update array modifiers = runST (thaw array >>= doUpdate modifiers)   where doUpdate l ma = loop l@@ -477,7 +483,7 @@  unsafeUpdate :: PrimType ty              => UArray ty-             -> [(Int, ty)]+             -> [(Offset ty, ty)]              -> UArray ty unsafeUpdate array modifiers = runST (thaw array >>= doUpdate modifiers)   where doUpdate l ma = loop l@@ -616,33 +622,36 @@ splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty] splitOn xpredicate ivec     | len == 0  = [mempty]-    | otherwise = runST $ unsafeIndexer ivec (go ivec xpredicate)+    | otherwise = runST $ unsafeIndexer ivec (pureST . go ivec xpredicate)   where-    !len = length ivec-    go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s [UArray ty]-    go v predicate getIdx = return (loop azero azero)+    !len = lengthSize ivec+    --go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s [UArray ty]+    go v predicate getIdx = loop 0 0       where-        loop !prevIdx@(Offset prevIdxo) !idx@(Offset idxo)-            | idx == Offset len = [sub v prevIdxo idxo]-            | otherwise          =+        loop !prevIdx !idx+            | idx .==# len = [sub v prevIdx idx]+            | otherwise    =                 let e = getIdx idx-                    idx' = idx + Offset 1+                    idx' = idx + 1                  in if predicate e-                        then sub v prevIdxo idxo : loop idx' idx'+                        then sub v prevIdx idx : loop idx' idx'                         else loop prevIdx idx'     {-# INLINE go #-} -sub :: PrimType ty => UArray ty -> Int -> Int -> UArray ty+pureST :: a -> ST s a+pureST = pure++sub :: PrimType ty => UArray ty -> Offset ty -> Offset ty -> UArray ty sub vec startIdx expectedEndIdx     | startIdx >= endIdx = empty     | otherwise          =         case vec of-            UVecBA start _ pinst ba -> UVecBA (start + Offset startIdx) newLen pinst ba-            UVecAddr start _ fptr   -> UVecAddr (start + Offset startIdx) newLen fptr+            UVecBA start _ pinst ba -> UVecBA (start + startIdx) newLen pinst ba+            UVecAddr start _ fptr   -> UVecAddr (start + startIdx) newLen fptr   where-    newLen = Offset endIdx - Offset startIdx-    endIdx = min expectedEndIdx len-    len = length vec+    newLen = endIdx - startIdx+    endIdx = min expectedEndIdx (0 `offsetPlusE` len)+    len = lengthSize vec  findIndex :: PrimType ty => ty -> UArray ty -> Maybe Int findIndex tyOuter ba = runST $ unsafeIndexer ba (go tyOuter)@@ -709,36 +718,40 @@         where t                  = primAddrIndex addr i {-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-} -intersperse :: PrimType ty => ty -> UArray ty -> UArray ty+intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty intersperse sep v     | len <= 1  = v-    | otherwise = runST $ unsafeCopyFrom v (len * 2 - 1) (go sep)-  where len = length v-        go :: PrimType ty => ty -> UArray ty -> Int -> MUArray ty s -> ST s ()-        go sep' oldV oldI newV-            | oldI == len - 1 = unsafeWrite newV newI e-            | otherwise       = do-                unsafeWrite newV newI e-                unsafeWrite newV (newI + 1) sep'-          where-            e = unsafeIndex oldV oldI-            newI = oldI * 2+    | otherwise = runST $ unsafeCopyFrom v newSize (go sep)+  where+    len = lengthSize v+    newSize = (scale (2:: Word) len) - 1 +    go :: PrimType ty => ty -> UArray ty -> Offset ty -> MUArray ty s -> ST s ()+    go sep' oldV oldI newV+        | oldI .==# (len - 1) = unsafeWrite newV newI e+        | otherwise           = do+            unsafeWrite newV newI e+            unsafeWrite newV (newI + 1) sep'+      where+        e = unsafeIndex oldV oldI+        newI = scale (2 :: Word) oldI+ span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) span p = break (not . p)  map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b-map f a = create (length a) (\i -> f $ unsafeIndex a i)+map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (lengthSize a) -mapIndex :: (PrimType a, PrimType b) => (Int -> a -> b) -> UArray a -> UArray b-mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i)+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))  cons :: PrimType ty => ty -> UArray ty -> UArray ty cons e vec     | len == Size 0 = singleton e     | otherwise     = runST $ do-        muv <- new (len + Size 1)-        unsafeCopyAtRO muv (Offset 1) vec (Offset 0) len+        muv <- new (len + 1)+        unsafeCopyAtRO muv 1 vec 0 len         unsafeWrite muv 0 e         unsafeFreeze muv   where@@ -750,7 +763,7 @@     | otherwise     = runST $ do         muv <- new (len + Size 1)         unsafeCopyAtRO muv (Offset 0) vec (Offset 0) len-        unsafeWrite muv (length vec) e+        unsafeWrite muv (0 `offsetPlusE` lengthSize vec) e         unsafeFreeze muv   where      !len = lengthSize vec@@ -758,40 +771,42 @@ uncons :: PrimType ty => UArray ty -> Maybe (ty, UArray ty) uncons vec     | nbElems == 0 = Nothing-    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 nbElems)+    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))   where-    !nbElems = length vec+    !nbElems = lengthSize vec  unsnoc :: PrimType ty => UArray ty -> Maybe (UArray ty, ty) unsnoc vec     | nbElems == 0 = Nothing     | otherwise    = Just (sub vec 0 lastElem, unsafeIndex vec lastElem)   where-    !lastElem = nbElems - 1-    !nbElems = length vec+    !lastElem = 0 `offsetPlusE` (nbElems - 1)+    !nbElems = lengthSize vec  find :: PrimType ty => (ty -> Bool) -> UArray ty -> Maybe ty find predicate vec = loop 0   where-    !len = length vec+    !len = lengthSize vec     loop i-        | i == len  = Nothing-        | otherwise =+        | i .==# len = Nothing+        | otherwise  =             let e = unsafeIndex vec i              in if predicate e then Just e else loop (i+1) -sortBy :: PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty-sortBy xford vec = runST (thaw vec >>= doSort xford)+sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty+sortBy xford vec+    | len == 0  = empty+    | otherwise = runST (thaw vec >>= doSort xford)   where-    len = length vec+    len = lengthSize vec     doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MUArray ty (PrimState prim) -> prim (UArray ty)-    doSort ford ma = qsort 0 (len - 1) >> unsafeFreeze ma+    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma       where         qsort lo hi             | lo >= hi  = return ()             | otherwise = do                 p <- partition lo hi-                qsort lo (p-1)+                qsort lo (pred p)                 qsort (p+1) hi         partition lo hi = do             pivot <- unsafeRead ma hi@@ -849,26 +864,26 @@ foldl :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a foldl f initialAcc vec = loop 0 initialAcc   where-    len = length vec+    len = lengthSize vec     loop i acc-        | i == len  = acc-        | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))  foldr :: PrimType ty => (ty -> a -> a) -> a -> UArray ty -> a foldr f initialAcc vec = loop 0   where-    len = length vec+    !len = lengthSize vec     loop i-        | i == len  = initialAcc-        | otherwise = unsafeIndex vec i `f` loop (i+1)+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)  foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a foldl' f initialAcc vec = loop 0 initialAcc   where-    len = length vec+    !len = lengthSize vec     loop i !acc-        | i == len  = acc-        | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))  builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state () builderAppend v = Builder $ State $ \(i, st) ->@@ -882,9 +897,8 @@                                       , curChunk       = newChunk                                       }))         else do-            let Offset i' = i-            unsafeWrite (curChunk st) i' v-            return ((), (i + Offset 1, st))+            unsafeWrite (curChunk st) i v+            return ((), (i + 1, st))  builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () -> m (UArray ty) builderBuild sizeChunksI ab

@@ -1,15 +1,14 @@ module Foundation.Array.Unboxed.ByteArray     ( MutableByteArray     , mutableByteArraySet-    , mutableByteArraySetBetween-    , mutableByteArrayMove+    -- , mutableByteArraySetBetween+    -- , mutableByteArrayMove     ) where  import Foundation.Internal.Base+import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Monad-import Foundation.Array.Common import Foundation.Array.Unboxed.Mutable-import Foundation.Numerical import Control.Monad (forM_)  -- | Mutable Byte Array alias@@ -18,19 +17,21 @@ mutableByteArraySet :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> prim () mutableByteArraySet mba val = do     -- naive haskell way. TODO: call memset or a 32-bit/64-bit method-    forM_ [0..(len-1)] $ \i -> unsafeWrite mba i val+    forM_ [0..(sizeLastOffset len)] $ \i -> unsafeWrite mba i val   where-    len = mutableLength mba+    len = mutableLengthSize mba -mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Int -> Int -> prim ()+{-+mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Offset Word8 -> Size Word8 -> prim () mutableByteArraySetBetween mba val offset size-    | offset < 0                        = throw (OutOfBound OOB_MemSet offset len)-    | offset > len || offset+size > len = throw (OutOfBound OOB_MemSet (offset+size) len)+    | offset < 0                        = primOutOfBound OOB_MemSet offset                      len+    | offset > len || offset+size > len = primOutOfBound OOB_MemSet (offset `OffsetPlusE` size) len     | otherwise =         -- TODO same as mutableByteArraySet-        forM_ [offset..(offset+size-1)] $ \i -> unsafeWrite mba i val+        forM_ [offset..(offset + sizeLastOffset size)] $ \i -> unsafeWrite mba i val   where-    len = mutableLength mba+    len = mutableLengthSize mba  mutableByteArrayMove :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Int -> Int -> Int -> prim () mutableByteArrayMove _mba _ofs _sz = undefined+    -}

@@ -18,6 +18,7 @@     -- * Property queries     , sizeInMutableBytesOfContent     , mutableLength+    , mutableLengthSize     , mutableSame     -- * Allocation & Copy     , new@@ -40,9 +41,9 @@ import           GHC.Ptr import           Foundation.Internal.Base import qualified Foundation.Internal.Environment as Environment-import           Foundation.Internal.Types import           Foundation.Internal.Primitive import           Foundation.Internal.Proxy+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           Foundation.Primitive.FinalPtr@@ -75,40 +76,40 @@ -- | read a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.-read :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Int -> prim ty+read :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty read array n-    | n < 0 || n >= len = primThrow (OutOfBound OOB_Read n len)-    | otherwise         = unsafeRead array n-  where len = mutableLength array+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise          = unsafeRead array n+  where len = mutableLengthSize array {-# INLINE read #-}  -- | read from a cell in a mutable array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values. -- use 'read' if unsure.-unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Int -> prim ty-unsafeRead (MUVecMA start _ _ mba) i = primMbaRead mba (start+.i)-unsafeRead (MUVecAddr start _ fptr) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start+.i)+unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MUVecMA start _ _ mba) i = primMbaRead mba (start + i)+unsafeRead (MUVecAddr start _ fptr) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i) {-# INLINE unsafeRead #-}  -- | Write to a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.-write :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Int -> ty -> prim ()+write :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim () write array n val-    | n < 0 || n >= len = primThrow (OutOfBound OOB_Write n len)-    | otherwise         = unsafeWrite array n val+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite array n val   where-    len = mutableLength array+    len = mutableLengthSize array {-# INLINE write #-}  -- | write to a cell in a mutable array without bounds checking. -- -- Writing with invalid bounds will corrupt memory and your program will -- become unreliable. use 'write' if unsure.-unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Int -> ty -> prim ()-unsafeWrite (MUVecMA start _ _ mba)  i v = primMbaWrite mba (start+.i) v-unsafeWrite (MUVecAddr start _ fptr) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+.i) v+unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()+unsafeWrite (MUVecMA start _ _ mba)  i v = primMbaWrite mba (start+i) v+unsafeWrite (MUVecAddr start _ fptr) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v {-# INLINE unsafeWrite #-}  -- | Create a new pinned mutable array of size @n.@@ -203,10 +204,10 @@     !(Size (I# nBytes)) = sizeOfE sz n copyAt dst od src os n = loop od os   where-    !(Offset endIndex) = os `offsetPlusE` n-    loop !(Offset d) !(Offset i)+    !endIndex = os `offsetPlusE` n+    loop !d !i         | i == endIndex = return ()-        | otherwise     = unsafeRead src i >>= unsafeWrite dst d >> loop (Offset $ d+1) (Offset $ i+1)+        | otherwise     = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1)  sub :: (PrimMonad prim, PrimType ty)     => MUArray ty (PrimState prim)@@ -248,6 +249,10 @@ mutableLength :: PrimType ty => MUArray ty st -> Int mutableLength (MUVecMA _ (Size end) _ _) = end mutableLength (MUVecAddr _ (Size end) _) = end++mutableLengthSize :: PrimType ty => MUArray ty st -> Size ty+mutableLengthSize (MUVecMA _ end _ _) = end+mutableLengthSize (MUVecAddr _ end _) = end  withMutablePtrHint :: (PrimMonad prim, PrimType ty)                    => Bool

@@ -6,7 +6,7 @@  import           Foundation.Internal.Base import           Foundation.Internal.MonadTrans-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad  newtype Builder collection mutCollection step state a = Builder

@@ -13,9 +13,13 @@     , Test(..)     , testName     -- * Property+    , PropertyCheck     , Property(..)     , IsProperty(..)     , (===)+    , propertyCompare+    , propertyAnd+    , propertyFail     -- * As Program     , defaultMain     ) where@@ -28,6 +32,7 @@ import           Foundation.Check.Gen import           Foundation.Check.Arbitrary import           Foundation.Check.Property+import           Foundation.Random import           Foundation.Monad import           Control.Exception (evaluate, SomeException) import           System.Exit@@ -76,27 +81,56 @@ nbFail (PropertyResult _ _ PropertySuccess)    = 0 nbFail (GroupResult    _ t _)                  = t -runProp :: Context -> String -> Property -> IO TestResult-runProp ctx s prop = do-    (\(e, i) -> PropertyResult s i e) <$> iterProp 0+-- | return the number of tests runned and the result+runProp :: Context -> String -> Property -> IO (PropertyResult, Word64)+runProp ctx s prop = iterProp 1   where     nbTests = 100     iterProp :: Word64 -> IO (PropertyResult, Word64)     iterProp i-        | i == nbTests = return (PropertySuccess, nbTests)+        | i == nbTests = return (PropertySuccess, i)         | otherwise    = do             r <- toResult i             case r of-                PropertyFailed e -> return (PropertyFailed e, i)-                PropertySuccess  -> iterProp (i+1)-    toResult :: Word64 -> IO PropertyResult+                (PropertyFailed e, _)               -> return (PropertyFailed e, i)+                (PropertySuccess, cont) | cont      -> iterProp (i+1)+                                        | otherwise -> return (PropertySuccess, i)+    toResult :: Word64 -> IO (PropertyResult, Bool)     toResult it =                 (propertyToResult <$> evaluate (runGen (unProp prop) (rngIt it) params))-        `catch` (\(e :: SomeException) -> return $ PropertyFailed (fromList $ show e))+        `catch` (\(e :: SomeException) -> return (PropertyFailed (fromList $ show e), False)) -    propertyToResult False = PropertyFailed "property failed"-    propertyToResult True  = PropertySuccess+    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 name _ _)  = []+    printChecks (PropertyBinaryOp False name a b) = [name <> " checked fail\n" <> "   left: " <> a <> "\n" <> "  right: " <> b]+    printChecks (PropertyNamed True _)            = []+    printChecks (PropertyNamed False name)        = ["Check " <> name <> " failed"]+    printChecks (PropertyBoolean True)            = []+    printChecks (PropertyBoolean False)           = ["Check failed"]+    printChecks (PropertyFail _ e)                = ["Check failed: " <> e]+    printChecks (PropertyAnd True _ _)            = []+    printChecks (PropertyAnd False a1 a2)+        | checkHasFailed a1 && checkHasFailed a2  = ["And Property failed:\n    && left: "] <> printChecks a1 <> ["\n"] <> ["   && right: "] <> printChecks a2+        | checkHasFailed a1                       = ["And Property failed:\n    && left: "] <> printChecks a1 <> ["\n"]+        | otherwise                               = ["And Property failed:\n   && right: "] <> printChecks a2 <> ["\n"]++    getArgs (PropertyArg a p) = a : getArgs p+    getArgs (PropertyEOA _) = []++    getChecks (PropertyArg _ p) = getChecks p+    getChecks (PropertyEOA c  ) = c+     !rngIt  = genRng (contextSeed ctx) (s : contextGroups ctx)     !params = GenParams { genMaxSizeIntegral = 32   -- 256 bits maximum numbers                         , genMaxSizeArray    = 512  -- 512 elements@@ -108,8 +142,10 @@ defaultMain test = do     -- parse arguments     --let arguments = [ "seed", "j" ]-    let seed = 10 +    -- generate a new seed+    seed <- getRandomPrimType+     let context = Context { contextLevel  = 0                           , contextGroups = []                           , contextSeed   = seed@@ -126,13 +162,17 @@      runTest :: Context -> Test -> IO TestResult     runTest ctx (Group s l) = do-        putStrLn s+        printIndent ctx s         results <- mapM (runTest (appendContext s ctx)) l         return $ GroupResult s (foldl' (+) 0 $ fmap nbFail results) results     runTest ctx (Property name prop) = do-        v <- runProp ctx name (property prop)-        putStrLn $ fromList (show v)-        return v+        (res, nbTests) <- runProp ctx name (property prop)+        case res of+            PropertySuccess  -> printIndent ctx $ "[  OK   ]   " <> name <> " (" <> fromList (show nbTests) <> " completed)"+            PropertyFailed e -> printIndent ctx $ "[ ERROR ]   " <> name <> " after " <> fromList (show (nbTests-1)) <> " tests\n" <> e+        return (PropertyResult name nbTests res)      runTest _ (Unit _ _) = do         error "not implemented"++    printIndent ctx s = putStrLn (replicate (contextLevel ctx) ' ' <> s)

@@ -12,6 +12,7 @@ import           Foundation.Internal.Natural import           Foundation.Primitive import           Foundation.Primitive.IntegralConv (wordToChar)+import           Foundation.Primitive.Floating (integerToDouble, naturalToDouble, doubleExponant) import           Foundation.Check.Gen import           Foundation.Random import           Foundation.Bits@@ -60,6 +61,11 @@ instance Arbitrary String where     arbitrary = genWithParams $ \params ->         fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (integralCast i) arbitrary)++instance Arbitrary Double where+    arbitrary = toDouble <$> arbitrary <*> arbitrary <*> arbitrary+      where toDouble i n Nothing  = integerToDouble i + (naturalToDouble n / 100000)+            toDouble i n (Just e) = (integerToDouble i + (naturalToDouble n / 1000000)) * (integerToDouble e)  instance Arbitrary a => Arbitrary (Maybe a) where     arbitrary = frequency $ nonEmpty_ [ (1, pure Nothing), (4, Just <$> arbitrary) ]

@@ -1,33 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-} module Foundation.Check.Property     ( Property(..)+    , PropertyTestArg(..)     , IsProperty+    , PropertyCheck(..)     , property+    , checkHasSucceed+    , checkHasFailed     -- * Properties     , forAll     , (===)+    , propertyCompare+    , propertyAnd+    , propertyFail     ) where  import Foundation.Internal.Base import Foundation.Check.Gen import Foundation.Check.Arbitrary+import Foundation.String +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++checkHasSucceed :: PropertyCheck -> PropertyTestResult+checkHasSucceed (PropertyBoolean b)        = b+checkHasSucceed (PropertyNamed b _)        = b+checkHasSucceed (PropertyBinaryOp b _ _ _) = b+checkHasSucceed (PropertyAnd b _ _)        = b+checkHasSucceed (PropertyFail b _)         = b++checkHasFailed :: PropertyCheck -> PropertyTestResult+checkHasFailed = not . checkHasSucceed++-- | A linked-list of arguments to this test+data PropertyTestArg = PropertyEOA PropertyCheck+                     | PropertyArg String PropertyTestArg++data Property = Prop { unProp :: Gen PropertyTestArg }+ class IsProperty p where     property :: p -> Property  instance IsProperty Bool where-    property b = Prop (pure b)+    property b = Prop $ pure (PropertyEOA $ PropertyBoolean b)+instance IsProperty (String, Bool) where+    property (name, b) = Prop $ pure (PropertyEOA $ PropertyNamed b name)+instance IsProperty PropertyCheck where+    property check = Prop $ pure (PropertyEOA check) instance IsProperty Property where-    property p = p -- (Prop result) = Prop . return $ result-instance IsProperty prop => IsProperty (Gen prop) where-    property mp = Prop (mp >>= \p -> unProp (property p))-instance (Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where+    property p = p+instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where     property p = forAll arbitrary p -data Property = Prop { unProp :: Gen Bool }--forAll :: IsProperty prop => Gen a -> (a -> prop) -> Property-forAll generator tst = Prop (generator >>= \a -> unProp (property (tst a)))+forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property+forAll generator tst = Prop $ do+    a <- generator+    augment a <$> unProp (property (tst a))+  where+    augment a arg = PropertyArg (fromList $ show a) arg -(===) :: Eq a => a -> a -> Property-(===) a b = Prop (pure (a == b))+(===) :: (Show a, Eq a) => a -> a -> PropertyCheck+(===) a b =+    let sa = fromList (show a)+        sb = fromList (show b)+     in PropertyBinaryOp (a == b) "==" sa sb infix 4 ===++propertyCompare :: Show a+                => String           -- ^ name of the function used for comparaison, e.g. (<)+                -> (a -> a -> Bool) -- ^ function used for value comparaison+                -> a                -- ^ value left of the operator+                -> a                -- ^ value right of the operator+                -> PropertyCheck+propertyCompare name op a b =+    let sa = fromList (show a)+        sb = fromList (show b)+     in PropertyBinaryOp (a `op` b) name sa sb++propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck+propertyAnd c1 c2 =+    PropertyAnd (checkHasSucceed c1 && checkHasSucceed c2) c1 c2++propertyFail :: String -> PropertyCheck+propertyFail = PropertyFail False

@@ -35,7 +35,7 @@ import           Foreign.C.Types (CChar, CUChar)  import Foundation.Internal.Base-import Foundation.Internal.Types+import Foundation.Primitive.Types.OffsetSize import Foundation.Internal.Proxy import Foundation.Collection import Foundation.Collection.Buildable (builderLift)

@@ -28,7 +28,7 @@ -- >>> import Control.Monad.ST -- >>> import Foundation.Array.Unboxed -- >>> import Foundation.Internal.Base--- >>> import Foundation.Internal.Types+-- >>> import Foundation.Primitive.OffsetSize  -- | Collections that can be built chunk by chunk. --

@@ -12,47 +12,49 @@     ) where  import           Foundation.Internal.Base+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection.Element import qualified Data.List import qualified Foundation.Array.Unboxed as UV import qualified Foundation.Array.Boxed as BA+import qualified Foundation.Array.Common as A import qualified Foundation.String.UTF8 as S  -- | Collection of elements that can indexed by int class IndexedCollection c where-    (!) :: c -> Int -> Maybe (Element c)-    findIndex :: (Element c -> Bool) -> c -> Maybe Int+    (!) :: c -> Offset (Element c) -> Maybe (Element c)+    findIndex :: (Element c -> Bool) -> c -> Maybe (Offset (Element c))  instance IndexedCollection [a] where-    (!) l n+    (!) l (Offset n)         | n < 0     = Nothing         | otherwise = case Data.List.drop n l of                         []  -> Nothing                         x:_ -> Just x-    findIndex = Data.List.findIndex+    findIndex predicate = fmap Offset . Data.List.findIndex predicate  instance UV.PrimType ty => IndexedCollection (UV.UArray ty) where     (!) l n-        | n < 0 || n >= UV.length l = Nothing-        | otherwise                 = Just $ UV.index l n+        | A.isOutOfBound n (UV.lengthSize l) = Nothing+        | otherwise                          = Just $ UV.index l n     findIndex predicate c = loop 0       where-        !len = UV.length c+        !len = UV.lengthSize c         loop i-            | i == len                       = Nothing+            | i .==# len                     = Nothing             | predicate (UV.unsafeIndex c i) = Just i             | otherwise                      = Nothing  instance IndexedCollection (BA.Array ty) where     (!) l n-        | n < 0 || n >= BA.length l = Nothing-        | otherwise                 = Just $ BA.index l n+        | A.isOutOfBound n (BA.lengthSize l) = Nothing+        | otherwise                          = Just $ BA.index l n     findIndex predicate c = loop 0       where-        !len = BA.length c+        !len = BA.lengthSize c         loop i-            | i == len  = Nothing-            | otherwise =+            | i .==# len = Nothing+            | otherwise  =                 if predicate (BA.unsafeIndex c i) then Just i else Nothing  instance IndexedCollection S.String where

@@ -10,8 +10,8 @@     ) where  import Foundation.Primitive.Monad+import Foundation.Primitive.Types.OffsetSize import Foundation.Internal.Base-import Foundation.Internal.Types  import qualified Foundation.Array.Unboxed.Mutable as MUV import qualified Foundation.Array.Unboxed as UV@@ -42,7 +42,7 @@  instance UV.PrimType ty => MutableCollection (MUV.MUArray ty) where     type MutableFreezed (MUV.MUArray ty) = UV.UArray ty-    type MutableKey (MUV.MUArray ty) = Int+    type MutableKey (MUV.MUArray ty) = Offset ty     type MutableValue (MUV.MUArray ty) = ty      thaw = UV.thaw@@ -59,7 +59,7 @@  instance MutableCollection (BA.MArray ty) where     type MutableFreezed (BA.MArray ty) = BA.Array ty-    type MutableKey (BA.MArray ty) = Int+    type MutableKey (BA.MArray ty) = Offset ty     type MutableValue (BA.MArray ty) = ty      thaw = BA.thaw

@@ -17,6 +17,7 @@     ) where  import           Foundation.Internal.Base+import           Foundation.Primitive.IntegralConv import           Foundation.Collection.Element import           Foundation.Collection.Collection import qualified Foundation.Collection.List as ListExtra@@ -35,6 +36,7 @@               , filter, reverse               , uncons, unsnoc, snoc, cons               , find, sortBy, singleton+              , replicate               #-}      -- | Take the first @n elements of a collection@@ -138,6 +140,9 @@     init :: NonEmpty c -> c     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+     -- | Takes two collections and returns True iff the first collection is a prefix of the second.     isPrefixOf :: Eq (Element c) => c -> c -> Bool     default isPrefixOf :: Eq c => c -> c -> Bool@@ -185,6 +190,7 @@     find = Data.List.find     sortBy = Data.List.sortBy     singleton = (:[])+    replicate i = Data.List.replicate (wordToInt i)     isPrefixOf = Data.List.isPrefixOf     isSuffixOf = Data.List.isSuffixOf @@ -209,6 +215,7 @@     find = UV.find     sortBy = UV.sortBy     singleton = fromList . (:[])+    replicate = UV.replicate  instance Sequential (BA.Array ty) where     take = BA.take@@ -230,6 +237,7 @@     find = BA.find     sortBy = BA.sortBy     singleton = fromList . (:[])+    replicate = BA.replicate  instance Sequential S.String where     take = S.take@@ -252,3 +260,4 @@     find = S.find     sortBy = S.sortBy     singleton = S.singleton+    replicate = S.replicate

@@ -42,7 +42,7 @@     ) where  import Foundation.Internal.Base-import Foundation.Internal.Types+import Foundation.Primitive.Types.OffsetSize import System.Posix.Types import Foreign.Ptr import Foreign.C.Types

@@ -13,8 +13,8 @@  import GHC.Ptr import Foundation.Primitive.FinalPtr+import Foundation.Primitive.Types.OffsetSize import Foundation.Internal.Base-import Foundation.Internal.Types import Foundation.VFS (FilePath)  -- | Contains all the information related to a file mapping,

@@ -7,8 +7,8 @@ import System.Win32.FileMapping import Control.Exception hiding (handle) -import Foundation.Internal.Types import Foundation.Internal.Base+import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.FinalPtr import Foundation.VFS import Foundation.Foreign.MemoryMap.Types

@@ -25,7 +25,7 @@  import           Foundation.Internal.Base import qualified Foundation.Array.Unboxed as A-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Types import           Foundation.Numerical import           Foundation.Hashing.Hasher

@@ -20,7 +20,7 @@  import           Data.Bits import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Types import           Foundation.Hashing.Hasher import qualified Foundation.Array.Unboxed as A

@@ -24,7 +24,7 @@ import qualified System.IO as S import           Foundation.Collection import           Foundation.VFS-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Internal.Base import           Foundation.String import           Foundation.Array@@ -137,16 +137,16 @@             r <- S.hGetBuf handle ptr blockSize             if r > 0 && r <= blockSize                 then do-                    (pos, validateRet) <- S.mutableValidate mv 0 r+                    (pos, validateRet) <- S.mutableValidate mv 0 (Size r)                     s <- case validateRet of-                        Nothing -> S.fromBytesUnsafe `fmap` V.freezeShrink mv r+                        Nothing -> S.fromBytesUnsafe `fmap` V.freezeShrink mv (Size r)                         Just S.MissingByte -> do-                            sRet <- S.fromBytesUnsafe `fmap` V.freezeShrink mv pos-                            V.unsafeSlide mv pos r+                            sRet <- S.fromBytesUnsafe `fmap` V.freezeShrink mv (pos - 0)+                            V.unsafeSlide mv pos (Offset r)                             return sRet                         Just _ ->                             error ("foldTextFile: invalid UTF8 sequence: byte position: " <> show (absPos + pos))-                    chunkf s acc >>= loop (absPos + r)+                    chunkf s acc >>= loop (absPos + Offset r)                 else error ("foldTextFile: read failed") -- FIXME  blockSize :: Int

@@ -23,7 +23,7 @@     ) where  import           Control.Exception-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Internal.Base import           Foundation.VFS (FilePath) import           Foundation.Primitive.FinalPtr

@@ -14,7 +14,7 @@     ) where  import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           System.IO.Unsafe          (unsafePerformIO)  #if MIN_VERSION_base(4,6,0)

@@ -10,11 +10,14 @@  #else -import Prelude (Show,Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise)+import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise) import Data.Typeable  newtype Natural = Natural Integer-    deriving (Show,Eq,Ord,Enum,Typeable)+    deriving (Eq,Ord,Enum,Typeable)++instance Show Natural where+    show (Natural i) = show i  -- re-create the buggy Num instance for Natural instance Num Natural where

@@ -1,117 +0,0 @@--- |--- Module      : Foundation.Internal.Types--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : portable----{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Foundation.Internal.Types-    ( FileSize(..)-    , Offset(..)-    , Offset8-    , offsetOfE-    , offsetPlusE-    , offsetMinusE-    , offsetRecast-    , (+.)-    , Size(..)-    , Size8-    , sizeOfE-    ) where--import GHC.Types-import GHC.Word-import Foundation.Internal.Base-import Foundation.Numerical.Primitives-import Foundation.Numerical.Number-import Foundation.Numerical.Additive-import Foundation.Numerical.Subtractive-import Foundation.Numerical.Multiplicative---- $setup--- >>> import Foundation.Array.Unboxed---- | File size in bytes-newtype FileSize = FileSize Word64-    deriving (Show,Eq,Ord)---- | Offset in bytes used for memory addressing (e.g. in a vector, string, ..)-type Offset8 = Offset Word8---- | Offset in a data structure consisting of elements of type 'ty'.------ Int is a terrible backing type which is hard to get away from,--- 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)--instance Integral (Offset ty) where-    fromInteger n-        | n < 0     = error "Size: 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)--(+.) :: Offset ty -> Int -> Offset ty-(+.) (Offset a) b = Offset (a + b)--offsetOfE :: Size8 -> Offset ty -> Offset8-offsetOfE (Size sz) (Offset ty) = Offset (ty * sz)--offsetPlusE :: Offset ty -> Size ty -> Offset ty-offsetPlusE (Offset ofs) (Size sz) = Offset (ofs + sz)--offsetMinusE :: Offset ty -> Size ty -> Offset ty-offsetMinusE (Offset ofs) (Size sz) = Offset (ofs - sz)--offsetRecast :: Size8 -> Size8 -> Offset ty -> Offset ty2-offsetRecast szTy (Size szTy2) ofs =-    let (Offset bytes) = offsetOfE szTy ofs-     in Offset (bytes `div` szTy2)---- | 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)---- | Size 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------ Same caveats as 'Offset' apply here.-newtype Size ty = Size Int-    deriving (Show,Eq,Ord,Enum)--sizeOfE :: Size8 -> Size ty -> Size8-sizeOfE (Size sz) (Size ty) = Size (ty * sz)

@@ -4,6 +4,7 @@  import           Foundation.Internal.Base import           Foundation.Internal.Natural+import           Foundation.Primitive.IntegralConv import qualified Prelude  -- | Represent class of things that can be subtracted.@@ -68,3 +69,6 @@ instance Subtractive Prelude.Double where     type Difference Prelude.Double = Prelude.Double     (-) = (Prelude.-)+instance Subtractive Prelude.Char where+    type Difference Prelude.Char = Prelude.Int+    (-) a b = (Prelude.-) (charToInt a) (charToInt b)

@@ -0,0 +1,21 @@+module Foundation.Primitive.Floating+    ( integerToDouble+    , naturalToDouble+    , doubleExponant+    ) where++import           GHC.Types+import           Foundation.Internal.Base+import           Foundation.Internal.Natural+import qualified Prelude (fromInteger, toInteger, (^^))++integerToDouble :: Integer -> Double+integerToDouble = Prelude.fromInteger+-- this depends on integer-gmp+--integerToDouble i = D# (doubleFromInteger i)++naturalToDouble :: Natural -> Double+naturalToDouble = integerToDouble . Prelude.toInteger++doubleExponant :: Double -> Int -> Double+doubleExponant = (Prelude.^^)

@@ -13,6 +13,8 @@     , word64ToWord32s     , word64ToWord     , wordToChar+    , wordToInt+    , charToInt     ) where  #include "MachDeps.h"@@ -86,6 +88,11 @@ instance IntegralUpsize Int32 Integer where     integralUpsize = fromIntegral +instance IntegralUpsize Int Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Int Int64 where+    integralUpsize = intToInt64+ instance IntegralUpsize Int64 Integer where     integralUpsize = fromIntegral @@ -97,6 +104,14 @@     integralUpsize (W8# i) = wordToWord64 (W# i) instance IntegralUpsize Word8 Word where     integralUpsize (W8# i) = W# i+instance IntegralUpsize Word8 Int16 where+    integralUpsize (W8# w) = I16# (word2Int# w)+instance IntegralUpsize Word8 Int32 where+    integralUpsize (W8# w) = I32# (word2Int# w)+instance IntegralUpsize Word8 Int64 where+    integralUpsize (W8# w) = intToInt64 (I# (word2Int# w))+instance IntegralUpsize Word8 Int where+    integralUpsize (W8# w) = I# (word2Int# w) instance IntegralUpsize Word8 Integer where     integralUpsize = fromIntegral instance IntegralUpsize Word8 Natural where@@ -122,11 +137,21 @@ instance IntegralUpsize Word32 Natural where     integralUpsize = fromIntegral +instance IntegralUpsize Word Integer where+    integralUpsize = fromIntegral+instance IntegralUpsize Word Natural where+    integralUpsize = fromIntegral+instance IntegralUpsize Word Word64 where+    integralUpsize = wordToWord64+ instance IntegralUpsize Word64 Integer where     integralUpsize = fromIntegral instance IntegralUpsize Word64 Natural where     integralUpsize = fromIntegral +instance IntegralUpsize Natural Integer where+    integralUpsize = fromIntegral+ instance IntegralDownsize Int Int8 where     integralDownsize      (I# i) = I8# (narrow8Int# i)     integralDownsizeCheck = integralDownsizeBounded integralDownsize@@ -254,11 +279,17 @@  #if WORD_SIZE_IN_BITS == 64 word64ToWord32s :: Word64 -> (# Word32, Word32 #)-word64ToWord32s (W64# w) = (# W32# (uncheckedShiftRL# w 32#), W32# (narrow32Word# w) #)+word64ToWord32s (W64# w64) = (# W32# (uncheckedShiftRL# w64 32#), W32# (narrow32Word# w64) #) #else word64ToWord32s :: Word64 -> (# Word32, Word32 #)-word64ToWord32s (W64# w) = (# W32# (word64ToWord# (uncheckedShiftRL64# w 32#)), W32# (word64ToWord# w) #)+word64ToWord32s (W64# w64) = (# W32# (word64ToWord# (uncheckedShiftRL64# w64 32#)), W32# (word64ToWord# w64) #) #endif  wordToChar :: Word -> Char-wordToChar (W# w) = C# (chr# (word2Int# w))+wordToChar (W# word) = C# (chr# (word2Int# word))++wordToInt :: Word -> Int+wordToInt (W# word) = I# (word2Int# word)++charToInt :: Char -> Int+charToInt (C# x) = I# (ord# x)

@@ -36,7 +36,7 @@ import           Foreign.C.Types import           Foundation.Internal.Proxy import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Endianness import           Foundation.Primitive.Monad import qualified Prelude (quot)

@@ -0,0 +1,142 @@+-- |+-- Module      : Foundation.Primitive.Types.OffsetSize+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+module Foundation.Primitive.Types.OffsetSize+    ( FileSize(..)+    , Offset(..)+    , Offset8+    , offsetOfE+    , offsetPlusE+    , offsetMinusE+    , offsetRecast+    , offsetCast+    , sizeCast+    , sizeLastOffset+    , (+.)+    , (.==#)+    , Size(..)+    , Size8+    , sizeOfE+    ) where++import GHC.Types+import GHC.Word+import Foundation.Internal.Base+import Foundation.Internal.Proxy+import Foundation.Numerical.Primitives+import Foundation.Numerical.Number+import Foundation.Numerical.Additive+import Foundation.Numerical.Subtractive+import Foundation.Numerical.Multiplicative++-- $setup+-- >>> import Foundation.Array.Unboxed++-- | File size in bytes+newtype FileSize = FileSize Word64+    deriving (Show,Eq,Ord)++-- | Offset in bytes used for memory addressing (e.g. in a vector, string, ..)+type Offset8 = Offset Word8++-- | Offset in a data structure consisting of elements of type 'ty'.+--+-- Int is a terrible backing type which is hard to get away from,+-- 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)++instance Integral (Offset ty) where+    fromInteger n+        | n < 0     = error "Size: 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)++(+.) :: Offset ty -> Int -> Offset ty+(+.) (Offset a) b = Offset (a + b)++-- . 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+{-# INLINE (.==#) #-}++offsetOfE :: Size8 -> Offset ty -> Offset8+offsetOfE (Size sz) (Offset ty) = Offset (ty * sz)++offsetPlusE :: Offset ty -> Size ty -> Offset ty+offsetPlusE (Offset ofs) (Size sz) = Offset (ofs + sz)++offsetMinusE :: Offset ty -> Size ty -> Offset ty+offsetMinusE (Offset ofs) (Size sz) = Offset (ofs - sz)++offsetRecast :: Size8 -> Size8 -> Offset ty -> Offset ty2+offsetRecast szTy (Size szTy2) ofs =+    let (Offset bytes) = offsetOfE szTy ofs+     in Offset (bytes `div` szTy2)++offsetCast :: Proxy (a -> b) -> Offset a -> Offset b+offsetCast _ (Offset o) = Offset o+{-# INLINE offsetCast #-}++sizeCast :: Proxy (a -> b) -> Size a -> Size b+sizeCast _ (Size sz) = Size sz+{-# INLINE sizeCast #-}++-- TODO add a callstack, or a construction to prevent size == 0 error+sizeLastOffset :: Size a -> Offset a+sizeLastOffset (Size s)+    | s > 0     = Offset (pred s)+    | otherwise = error "last offset on size 0"++-- | 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)++-- | Size 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+--+-- Same caveats as 'Offset' apply here.+newtype Size ty = Size Int+    deriving (Show,Eq,Ord,Enum)++sizeOfE :: Size8 -> Size ty -> Size8+sizeOfE (Size sz) (Size ty) = Size (ty * sz)

@@ -17,7 +17,7 @@     ) where  import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Internal.Primitive import           Foundation.Primitive.Monad import           GHC.Prim

@@ -28,7 +28,7 @@     ) where  import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Internal.Proxy import           Foundation.Primitive.Monad import           Foundation.System.Entropy

@@ -37,7 +37,7 @@ import qualified Foundation.Array.Unboxed.Mutable   as MVec import qualified Foundation.Collection              as C import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Foreign@@ -106,13 +106,14 @@     find = find     sortBy = sortBy     singleton = fromList . (:[])+    replicate n = fromList . C.replicate n  instance C.Zippable AsciiString where   -- TODO Use a string builder once available   zipWith f a b = sFromList (C.zipWith f a b)  next :: AsciiString -> Offset CUChar -> (# CUChar, Offset CUChar #)-next (AsciiString ba) (Offset n) = (# h, Offset (n + 1) #)+next (AsciiString ba) n = (# h, n + 1 #)   where     !h = Vec.unsafeIndex ba n @@ -209,7 +210,7 @@ length s = let (Size l) = size s in l  replicate :: Int -> CUChar -> AsciiString-replicate n c = AsciiString $ Vec.create n (const c)+replicate n c = AsciiString $ Vec.create (Size n) (const c)  -- | Copy the AsciiString copy :: AsciiString -> AsciiString

@@ -14,7 +14,7 @@     ) where  import Foundation.Internal.Base-import Foundation.Internal.Types+import Foundation.Primitive.Types.OffsetSize import Foundation.Numerical import Foundation.Primitive.Monad 

@@ -14,7 +14,7 @@     ) where  import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           Foundation.Boot.Builder

@@ -14,7 +14,7 @@     ) where  import Foundation.Internal.Base-import Foundation.Internal.Types+import Foundation.Primitive.Types.OffsetSize import Foundation.Numerical import Foundation.Primitive.Monad 

@@ -12,7 +12,7 @@     ) where  import Foundation.Internal.Base-import Foundation.Internal.Types+import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Monad import GHC.Prim import GHC.Word

@@ -12,7 +12,7 @@     ) where  import Foundation.Internal.Base-import Foundation.Internal.Types+import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Monad import GHC.Prim import GHC.Word

@@ -25,7 +25,7 @@ import           Control.Monad (mapM_)  import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import qualified Foundation.Array.Unboxed as Vec import           Foundation.Array.Unboxed (UArray) import           Foundation.Numerical

@@ -0,0 +1,8 @@+module Foundation.String.Read+    ( readInteger+    , readNatural+    , readDouble+    , readFloatingExact+    ) where++import Foundation.String.UTF8

@@ -66,6 +66,10 @@     , reverse     , builderAppend     , builderBuild+    , readInteger+    , readNatural+    , readDouble+    , readFloatingExact     -- * Legacy utility     , lines     , words@@ -77,12 +81,16 @@ import           Foundation.Array.Unboxed.ByteArray (MutableByteArray) import qualified Foundation.Array.Unboxed.Mutable   as MVec import           Foundation.Internal.Base+import           Foundation.Bits+import           Foundation.Internal.Natural import           Foundation.Internal.MonadTrans import           Foundation.Internal.Primitive-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Primitive.Types+import           Foundation.Primitive.IntegralConv+import           Foundation.Primitive.Floating import           Foundation.Boot.Builder import qualified Foundation.Boot.List as List import           Foundation.String.UTF8Table@@ -212,13 +220,13 @@ -- | Similar to 'validate' but works on a 'MutableByteArray' mutableValidate :: PrimMonad prim                 => MutableByteArray (PrimState prim)-                -> Int-                -> Int-                -> prim (Int, Maybe ValidationFailure)+                -> Offset Word8+                -> Size Word8+                -> prim (Offset Word8, Maybe ValidationFailure) mutableValidate mba ofsStart sz = do     loop ofsStart   where-    end = ofsStart + sz+    end = ofsStart `offsetPlusE` sz      loop ofs         | ofs > end  = error "mutableValidate: internal error: went pass offset"@@ -234,7 +242,7 @@         let nbConts = getNbBytes h         if nbConts == 0xff             then return (pos, Just InvalidHeader)-            else if pos + 1 + nbConts > end+            else if pos + 1 + Offset nbConts > end                 then return (pos, Just MissingByte)                 else do                     case nbConts of@@ -342,16 +350,24 @@     toContinuation :: Word# -> Word#     toContinuation w = or# (and# w 0x3f##) 0x80## +-- A variant of 'next' when you want the next character+-- to be ASCII only. if Bool is False, then it's not ascii,+-- otherwise it is and the return Word8 is valid.+nextAscii :: String -> Offset8 -> (# Word8, Bool #)+nextAscii (String ba) n = (# w, not (testBit w 7) #)+  where+    !w = Vec.unsafeIndex ba n+ next :: String -> Offset8 -> (# Char, Offset8 #)-next (String ba) (Offset n) =+next (String ba) n =     case getNbBytes# h of-        0# -> (# toChar h, Offset $ n + 1 #)-        1# -> (# toChar (decode2 (Vec.unsafeIndex ba (n + 1))) , Offset $ n + 2 #)+        0# -> (# toChar h, n + 1 #)+        1# -> (# toChar (decode2 (Vec.unsafeIndex ba (n + 1))) , n + 2 #)         2# -> (# toChar (decode3 (Vec.unsafeIndex ba (n + 1))-                                 (Vec.unsafeIndex ba (n + 2))) , Offset $ n + 3 #)+                                 (Vec.unsafeIndex ba (n + 2))) , n + 3 #)         3# -> (# toChar (decode4 (Vec.unsafeIndex ba (n + 1))                                  (Vec.unsafeIndex ba (n + 2))-                                 (Vec.unsafeIndex ba (n + 3))) , Offset $ n + 4 #)+                                 (Vec.unsafeIndex ba (n + 3))) , n + 4 #)         r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show (I# r) <> " h=" <> show (W# h))   where     !(W8# h) = Vec.unsafeIndex ba n@@ -423,16 +439,16 @@ numBytes UTF8_4{} = Size 4  writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim ()-writeUTF8Char (MutableString mba) (Offset i) (UTF8_1 x1) =+writeUTF8Char (MutableString mba) i (UTF8_1 x1) =     Vec.unsafeWrite mba i     x1-writeUTF8Char (MutableString mba) (Offset i) (UTF8_2 x1 x2) = do+writeUTF8Char (MutableString mba) i (UTF8_2 x1 x2) = do     Vec.unsafeWrite mba i     x1     Vec.unsafeWrite mba (i+1) x2-writeUTF8Char (MutableString mba) (Offset i) (UTF8_3 x1 x2 x3) = do+writeUTF8Char (MutableString mba) i (UTF8_3 x1 x2 x3) = do     Vec.unsafeWrite mba i     x1     Vec.unsafeWrite mba (i+1) x2     Vec.unsafeWrite mba (i+2) x3-writeUTF8Char (MutableString mba) (Offset i) (UTF8_4 x1 x2 x3 x4) = do+writeUTF8Char (MutableString mba) i (UTF8_4 x1 x2 x3 x4) = do     Vec.unsafeWrite mba i     x1     Vec.unsafeWrite mba (i+1) x2     Vec.unsafeWrite mba (i+2) x3@@ -440,7 +456,7 @@ {-# INLINE writeUTF8Char #-}  write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8-write (MutableString mba) (Offset i) c =+write (MutableString mba) i c =     if      bool# (ltWord# x 0x80##   ) then encode1     else if bool# (ltWord# x 0x800##  ) then encode2     else if bool# (ltWord# x 0x10000##) then encode3@@ -449,14 +465,14 @@     !(I# xi) = fromEnum c     !x       = int2Word# xi -    encode1 = Vec.unsafeWrite mba i (W8# x) >> return (Offset $ i + 1)+    encode1 = Vec.unsafeWrite mba i (W8# x) >> return (i + 1)      encode2 = do         let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##             x2  = toContinuation x         Vec.unsafeWrite mba i     (W8# x1)         Vec.unsafeWrite mba (i+1) (W8# x2)-        return $ Offset (i + 2)+        return (i + 2)      encode3 = do         let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##@@ -465,7 +481,7 @@         Vec.unsafeWrite mba i     (W8# x1)         Vec.unsafeWrite mba (i+1) (W8# x2)         Vec.unsafeWrite mba (i+2) (W8# x3)-        return $ Offset (i + 3)+        return (i + 3)      encode4 = do         let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##@@ -476,7 +492,7 @@         Vec.unsafeWrite mba (i+1) (W8# x2)         Vec.unsafeWrite mba (i+2) (W8# x3)         Vec.unsafeWrite mba (i+3) (W8# x4)-        return $ Offset (i + 4)+        return (i + 4)      toContinuation :: Word# -> Word#     toContinuation w = or# (and# w 0x3f##) 0x80##@@ -544,14 +560,14 @@ take n s@(String ba)     | n <= 0           = mempty     | n >= C.length ba = s-    | otherwise        = let (Offset o) = indexN n s in String $ Vec.take o ba+    | otherwise        = let (Offset o) = indexN (Offset n) s in String $ Vec.take o ba  -- | Create a string with the remaining Chars after dropping @n Chars from the beginning drop :: Int -> String -> String drop n s@(String ba)     | n <= 0           = s     | n >= C.length ba = mempty-    | otherwise        = let (Offset o) = indexN n s in String $ Vec.drop o ba+    | otherwise        = let (Offset o) = indexN (Offset n) s in String $ Vec.drop o ba  -- | Split a string at the Offset specified (in Char) returning both -- the leading part and the remaining part.@@ -560,25 +576,21 @@     | nI <= 0           = (mempty, s)     | nI >= C.length ba = (s, mempty)     | otherwise =-        let (Offset k) = indexN nI s+        let (Offset k) = indexN (Offset nI) s             (v1,v2)    = C.splitAt k ba          in (String v1, String v2)  -- | Return the offset (in bytes) of the N'th sequence in an UTF8 String-indexN :: Int -> String -> Offset Word8-indexN nI (String ba) = Vec.unsafeDewrap goVec goAddr ba+indexN :: Offset Char -> String -> Offset Word8+indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba   where-    !n = Size nI-    end :: Offset Char-    !end = Offset 0 `offsetPlusE` n-     goVec :: ByteArray# -> Offset Word8 -> Offset Word8     goVec !ma !start = loop start (Offset 0)       where         !len = start `offsetPlusE` Vec.lengthSize ba         loop :: Offset Word8 -> Offset Char -> Offset Word8         loop !idx !i-            | idx >= len || i >= end = sizeAsOffset (idx - start)+            | idx >= len || i >= n = sizeAsOffset (idx - start)             | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)           where d = skipNextHeaderValue (primBaIndex ma idx)     {-# INLINE goVec #-}@@ -589,8 +601,8 @@         !len = start `offsetPlusE` Vec.lengthSize ba         loop :: Offset Word8 -> Offset Char -> Offset Word8         loop !idx !i-            | idx >= len || i >= end = 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 #-}@@ -641,7 +653,7 @@ -- This is unsafe considering that one can create a substring -- starting and/or ending on the middle of a UTF8 sequence. sub :: String -> Offset8 -> Offset8 -> String-sub (String ba) (Offset start) (Offset end) = String $ Vec.sub ba start end+sub (String ba) start end = String $ Vec.sub ba start end  -- | Internal call to split at a given index in offset of bytes. --@@ -807,18 +819,18 @@ length s = let (Size sz) = lengthSize s in sz  -- | Replicate a character @c@ @n@ times to create a string of length @n@-replicate :: Int -> Char -> String+replicate :: Word -> Char -> String replicate n c = runST (new nbBytes >>= fill)   where-    end       = azero `offsetPlusE` nbBytes-    nbBytes   = Size $ sz * n-    (Size sz) = charToBytes (fromEnum c)+    --end       = azero `offsetPlusE` nbBytes+    nbBytes   = scale n sz+    sz = charToBytes (fromEnum c)     fill :: PrimMonad prim => MutableString (PrimState prim) -> prim String     fill ms = loop (Offset 0)       where         loop idx-            | idx == end = freeze ms-            | otherwise  = write ms idx c >>= loop+            | idx .==# nbBytes = freeze ms+            | otherwise        = write ms idx c >>= loop  -- | Copy the String --@@ -955,7 +967,7 @@ unsnoc :: String -> Maybe (String, Char) unsnoc s     | null s    = Nothing-    | otherwise = case index s (length s - 1) of+    | otherwise = case index s (sizeLastOffset $ lengthSize s) of         Nothing -> Nothing         Just c  -> Just (revDrop 1 s, c) @@ -1000,14 +1012,14 @@     !len = size s     -- write those bytes     loop :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Offset8 -> prim String-    loop ms@(MutableString mba) sidx@(Offset si) didx+    loop ms@(MutableString mba) si didx         | didx == Offset 0 = freeze ms         | otherwise = do             let !h = Vec.unsafeIndex ba si                 !nb = Size (getNbBytes h + 1)-                didx'@(Offset d) = didx `offsetMinusE` nb+                d  = didx `offsetMinusE` nb             case nb of-                Size 1 -> Vec.unsafeWrite mba d      h+                Size 1 -> Vec.unsafeWrite mba d h                 Size 2 -> do                     Vec.unsafeWrite mba d       h                     Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))@@ -1021,13 +1033,13 @@                     Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))                     Vec.unsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3))                 _  -> return () -- impossible-            loop ms (sidx `offsetPlusE` nb) didx'+            loop ms (si `offsetPlusE` nb) d  -- | Return the nth character in a String -- -- Compared to an array, the string need to be scanned from the beginning -- since the UTF8 encoding is variable.-index :: String -> Int -> Maybe Char+index :: String -> Offset Char -> Maybe Char index s n     | ofs >= end = Nothing     | otherwise  =@@ -1041,18 +1053,17 @@ -- | Return the index in unit of Char of the first occurence of the predicate returning True -- -- If not found, Nothing is returned-findIndex :: (Char -> Bool) -> String -> Maybe Int-findIndex predicate s = loop (Offset 0)+findIndex :: (Char -> Bool) -> String -> Maybe (Offset Char)+findIndex predicate s = loop 0 0   where     !sz = size s-    end = Offset 0 `offsetPlusE` sz-    loop idx-        | idx == end = Nothing-        | otherwise =+    loop ofs idx+        | idx .==# sz = Nothing+        | otherwise   =             let (# c, idx' #) = next s idx              in case predicate c of-                    True  -> let (Offset r) = idx in Just r-                    False -> loop idx'+                    True  -> Just ofs+                    False -> loop (ofs+1) idx'  -- | Various String Encoding that can be use to convert to and from bytes data Encoding@@ -1238,3 +1249,185 @@         let sz = Vec.lengthSize x         Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz         fillFromEnd (end - sz) xs mba++-- | Read an Integer from a String+--+-- Consume an optional minus sign and many digits until end of string.+readInteger :: String -> Maybe Integer+readInteger str+    | sz == 0  = Nothing+    | otherwise =+         let (# modF, startOfs #) = case nextAscii str 0 of+                                        -- '-'+                                        (# 0x2d, True #) -> (# negate , 1 #)+                                        _                -> (# id, 0 #)+          in case decimalDigits 0 str startOfs of+                (# acc, True, endOfs #) | endOfs > startOfs -> Just $ modF acc+                _                                           -> Nothing+  where+    !sz = size str++-- | Read a Natural from a String+--+-- Consume many digits until end of string.+readNatural :: String -> Maybe Natural+readNatural str+    | sz == 0  = Nothing+    | otherwise =+        case decimalDigits 0 str 0 of+            (# acc, True, endOfs #) | endOfs > 0 -> Just $ acc+            _                                    -> Nothing+  where+    !sz = size str++-- | Try to read a Double+readDouble :: String -> Maybe Double+readDouble s =+    readFloatingExact s $ \isNegative integral mFloating mExponant ->+        case (mFloating, mExponant) of+            (Nothing, Nothing)             -> Just $ applySign isNegative $                         naturalToDouble integral+            (Nothing, Just exponant)       -> Just $ applySign isNegative $ withExponant exponant $ naturalToDouble integral+            (Just floating, Nothing)       -> Just $ applySign isNegative $                         (naturalToDouble integral + floatingToDouble floating)+            (Just floating, Just exponant) -> Just $ applySign isNegative $ withExponant exponant $ (naturalToDouble integral + floatingToDouble floating)+  where+    applySign True = negate+    applySign False = id+    withExponant e v = v * doubleExponant 10 e+    floatingToDouble (digits, n) = naturalToDouble n / (10 ^ digits)++type ReadFloatingCallback a = Bool                  -- sign+                           -> Natural               -- integral part+                           -> Maybe (Word, Natural) -- optional number of zero and number representing floating part+                           -> Maybe Int             -- optional integer representing exponent in base 10+                           -> Maybe a++-- | Read an Floating like number of the form:+--+--   [ '-' ] <numbers> [ '.' <numbers> ] [ ( 'e' | 'E' ) [ '-' ] <number> ]+--+-- Call a function with:+--+-- * A boolean representing if the number is negative+-- * The leading integral part+-- * The floating part (number of digits after fractional part, and number) if any+-- * The exponant if any+--+-- The code is structured as a simple state machine that:+--+-- * Optionally Consume a '-' sign+-- * Consume number for the integral part+-- * Optionally+--   * Consume '.'+--   * Consume leading zeros explicitely to gather scale of the fractional part+--   * Consume remaining digits if not already end of string+-- * Optionally Consume a 'e' or 'E' follow by an optional '-' and a number+--+readFloatingExact :: String -> ReadFloatingCallback a -> Maybe a+readFloatingExact str f+    | sz == 0   = Nothing+    | otherwise =+        -- try to eat a '-', otherwise call consumeIntegral+        case nextAscii str 0 of+            (# _   , False #) -> Nothing+            (# 0x2d, True #)  -> consumeIntegral True 1+            _                 -> consumeIntegral False 0+  where+    !sz = size str++    consumeIntegral isNegative startOfs =+        case decimalDigits 0 str startOfs of+            (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc Nothing Nothing -- end of stream and no '.'+            (# acc, False, endOfs #) | endOfs > startOfs -> consumeDot isNegative acc endOfs+            _                                            -> Nothing++    -- this is not the end of the stream since otherwise consumeIntegral would have+    -- returned already+    -- try either to consume '.' or pass state to consumeExponant+    consumeDot isNegative integral startOfs =+        case nextAscii str startOfs of+            (# _   , False #) -> Nothing+            (# 0x2e, True #)  -> consumeZero isNegative integral (startOfs + 1)+            (# _   , True #)  -> consumeExponant isNegative integral Nothing startOfs++    consumeZero isNegative integral startOfs = loop 0 startOfs+      where+        loop nbDigits ofs+            | ofs .==# sz = if nbDigits == 0 then Nothing else f isNegative integral (Just (nbDigits, 0)) Nothing+            | otherwise   =+                case nextAscii str ofs of+                    (# _   , False #) -> Nothing+                    (# 0x30, True #)  -> loop (nbDigits+1) (ofs+1)+                    (# c   , True #)+                        | c == 0x45 || c == 0x65 -> if nbDigits > 0 then consumeExponant isNegative integral (Just (nbDigits, 0)) ofs else Nothing+                        | otherwise              -> consumeFloat isNegative integral nbDigits ofs++    consumeFloat isNegative integral nbDigits startOfs =+        case decimalDigits 0 str startOfs of+            (# acc, True, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                                                            in f isNegative integral (Just (nbDigits+integralCast diff, acc)) Nothing+            (# acc, False, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                                                            in consumeExponant isNegative integral (Just (nbDigits+integralCast diff, acc)) endOfs+            _                                           -> Nothing++    consumeExponant !isNegative !integral !floating !startOfs+        | startOfs .==# sz = f isNegative integral floating Nothing+        | otherwise        =+            -- consume 'E' or 'e'+            case nextAscii str startOfs of+                (# _   , False #) -> Nothing -- more character but no ascii+                (# 0x45, True  #) -> consumeExponantSign (startOfs+1)+                (# 0x65, True  #) -> consumeExponantSign (startOfs+1)+                (# _   , True  #) -> Nothing+      where+        consumeExponantSign ofs+            | ofs .==# sz = Nothing+            | otherwise   =+                case nextAscii str ofs of+                    (# _   , False #) -> Nothing+                    (# 0x2d, True  #) -> consumeExponantNumber negate (ofs+1)+                    (# _   , True  #) -> consumeExponantNumber id     ofs+        consumeExponantNumber signFct ofs =+            case decimalDigits 0 str ofs of+                (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floating (Just $ signFct acc)+                _                                      -> Nothing++-- | Take decimal digits and accumulate it in `acc`+--+-- The loop starts at the offset specified and finish either when:+--+-- * It reach the end of the string+-- * It reach a non-ASCII character+-- * It reach an ASCII character that is not a digit (0 to 9)+--+-- Otherwise each iterations:+--+-- * Transform the ASCII digits into a number+-- * scale the accumulator by 10+-- * Add the number (between 0 and 9) to the accumulator+--+-- It then returns:+--+-- * The new accumulated value+-- * Whether it stop by end of string or not+-- * The end offset when the loop stopped+--+-- If end offset == start offset then no digits have been consumed by+-- this function+decimalDigits :: (IntegralUpsize Word8 acc, Additive acc)+              => acc+              -> String+              -> Offset Word8+              -> (# acc, Bool, Offset Word8 #)+decimalDigits startAcc str startOfs = loop startAcc startOfs+  where+    !sz = size str+    loop acc ofs+        | ofs .==# sz = (# acc, True, ofs #)+        | otherwise   =+            case nextAscii str ofs of+                (# d, True #) | isDigit d -> loop (scale (10::Word) acc + fromDigit d) (ofs+1)+                (# _, _ #)                -> (# acc, False, ofs #)+    ascii0 = 0x30 -- use pattern synonym when we support >= 8.0+    ascii9 = 0x39+    isDigit c = c >= ascii0 && c <= ascii9+    fromDigit c = integralUpsize (c - ascii0)

@@ -12,7 +12,7 @@   import           Foundation.Internal.Base-import           Foundation.Internal.Types+import           Foundation.Primitive.Types.OffsetSize import qualified Foundation.Array.Unboxed.Mutable as A import qualified Foundation.Array.Unboxed as A import           Control.Exception

@@ -132,3 +132,15 @@   Foundation uses and abuses type families.+++Code Organisation+=================++Every foundation modules start by `Foundation`.++* `Foundation` is the prelude replacement module.+* `Foundation.Internal` contains only compatibilty and re-export from ghc/ghc-prim/base.+* `Foundation.Primitive` is where all the lowlevel magic happens:+  * Important types that underpins many others part+  * Pervasive features

@@ -1,5 +1,5 @@ Name:                foundation-Version:             0.0.6+Version:             0.0.7 Synopsis:            Alternative prelude with batteries and no dependencies Description:     A custom prelude with no dependencies apart from base.@@ -38,6 +38,11 @@   type: git   location: https://github.com/haskell-foundation/foundation +Flag experimental+  Description:       Enable building experimental features, known as highly unstable or without good support cross-platform+  Default:           False+  Manual:            False+ Flag bench-all   Description:       Add some comparaison benchmarks against other haskell libraries   Default:           False@@ -60,6 +65,7 @@                      Foundation.Convertible                      Foundation.String                      Foundation.String.ASCII+                     Foundation.String.Read                      Foundation.IO                      Foundation.IO.FileMap                      Foundation.VFS@@ -76,7 +82,6 @@                      Foundation.Monad.State                      Foundation.Network.IPv4                      Foundation.Network.IPv6-                     Foundation.Network.HostName                      Foundation.System.Info                      Foundation.Strict                      Foundation.Parser@@ -127,7 +132,6 @@                      Foundation.Internal.IsList                      Foundation.Internal.Identity                      Foundation.Internal.Proxy-                     Foundation.Internal.Types                      Foundation.Internal.PrimTypes                      Foundation.Internal.MonadTrans                      Foundation.Internal.Natural@@ -143,9 +147,11 @@                      Foundation.Primitive.Base16                      Foundation.Primitive.Endianness                      Foundation.Primitive.Types+                     Foundation.Primitive.Types.OffsetSize                      Foundation.Primitive.Monad                      Foundation.Primitive.Utils                      Foundation.Primitive.IntegralConv+                     Foundation.Primitive.Floating                      Foundation.Primitive.FinalPtr                      Foundation.Monad.MonadIO                      Foundation.Monad.Exception@@ -169,6 +175,8 @@   C-sources:         cbits/foundation_random.c                      cbits/foundation_network.c +  if flag(experimental)+    Exposed-modules: Foundation.Network.HostName   if os(windows)     Exposed-modules: Foundation.System.Bindings.Windows     Other-modules:   Foundation.Foreign.MemoryMap.Windows

@@ -2,9 +2,13 @@ module Main where  import Foundation+import Foundation.Primitive import Foundation.Check+import Foundation.String.Read+import Foundation.Numerical+import qualified Prelude -testAdditive :: forall a . (Eq a, Additive a, Arbitrary a) => Proxy a -> Test+testAdditive :: forall a . (Show a, Eq a, Additive a, Arbitrary a) => Proxy a -> Test testAdditive _ = Group "Additive"     [ Property "eq"             $ azero === (azero :: a)     , Property "a + azero == a" $ \(v :: a)     -> v + azero === v@@ -12,6 +16,18 @@     , Property "a + b == b + a" $ \(v1 :: a) v2 -> v1 + v2 === v2 + v1     ] +readFloatingExact' :: String -> Maybe (Bool, Natural, Maybe (Word, Natural), Maybe Int)+readFloatingExact' s = readFloatingExact s (\s x y z -> Just (s,x,y,z))++doubleEqualApprox :: Double -> Double -> PropertyCheck+doubleEqualApprox d1 d2 = (propertyCompare pName1 (<) (negate lim) d) `propertyAnd` (propertyCompare pName2 (<) d lim)+  where +        d = d2 - d1++        pName1 = show (negate lim) <> " < " <> show d2 <> " - " <> show d1 <> " (== " <> show d <> " )"+        pName2 = show d1 <> " - " <> show d2 <> " (== " <> show d <> " )" <> " < " <> show lim+        lim = 1.0e-8+ main = defaultMain $ Group "foundation"     [ Group "Numerical"         [ Group "Int"@@ -20,10 +36,38 @@         , Group "Word64"             [ testAdditive (Proxy :: Proxy Word64)             ]-{--        , Group "Natural"-            [ testAdditive (Proxy :: Proxy Natural)+        ]+    , Group "String"+        [ Group "reading"+            [ Group "integer"+                [ Property "empty"         $ readInteger "" === Nothing+                , Property "just-sign"     $ readInteger "-" === Nothing+                , Property "extra-content" $ readInteger "-123a" === Nothing+                , Property "any"           $ \i -> readInteger (show i) === Just i+                ]+            , Group "floating-exact"+                [ Property "empty"         $ readFloatingExact' "" === Nothing+                , Property "just-sign"     $ readFloatingExact' "-" === Nothing+                , Property "extra-content" $ readFloatingExact' "-123a" === Nothing+                , Property "no-dot-after"  $ readFloatingExact' "-123." === Nothing+                , Property "case1"         $ readFloatingExact' "-123.1" === Just (True, 123, Just (1, 1), Nothing)+                , Property "case2"         $ readFloatingExact' "10001.001" === Just (False, 10001, Just (3, 1), Nothing)+                , Property "any"           $ \s i (v :: Word8) n ->+                                                let vw = integralUpsize v :: Word+                                                    sfloat = show n+                                                    digits = integralCast (length sfloat) + vw+                                                 in readFloatingExact' ((if s then "-" else "") <> show i <> "." <> replicate vw '0' <> sfloat) === Just (s, i, Just (digits, n), Nothing)+                ]+            , Group "Double"+                [ Property "case1" $ readDouble "96152.5" === Just 96152.5+                , Property "case2" $ maybe (propertyFail "Nothing") (doubleEqualApprox 1.2300000000000002e102) $ readDouble "1.2300000000000002e102"+                , Property "case3" $ maybe (propertyFail "Nothing") (doubleEqualApprox 0.00001204) $ readDouble "0.00001204"+                , Property "case4" $ maybe (propertyFail "Nothing") (doubleEqualApprox 2.5e12) $ readDouble "2.5e12"+                , Property "case5" $ maybe (propertyFail "Nothing") (doubleEqualApprox 6.0e-4) $ readDouble "6.0e-4"+                , Property "Prelude.read" $ \(d :: Double) -> case readDouble (show d) of+                                                                  Nothing -> propertyFail "Nothing"+                                                                  Just d' -> d' `doubleEqualApprox` (Prelude.read $ toList $ show d)+                ]             ]--}         ]     ]

@@ -26,6 +26,7 @@ import Test.Tasty.HUnit        as X hiding (testCase, assert, assertFailure) import Test.QuickCheck.Monadic as X + import qualified Test.Tasty            as Y import qualified Test.Tasty.QuickCheck as Y import qualified Test.Tasty.HUnit      as Y

@@ -71,7 +71,7 @@  -- | Append random data to the test state randomTestAppend :: RandomTestState s -> UArray Word8 -> ST s ()-randomTestAppend (RandomTestState buckets) = mapM_ (addVec 1 . fromIntegral) . toList+randomTestAppend (RandomTestState buckets) = mapM_ (addVec 1 . Offset . fromIntegral) . toList   where     addVec a i = mutRead buckets i >>= \d -> mutWrite buckets i $! d+a 

@@ -10,7 +10,6 @@ import Foundation import Foundation.String import Foundation.String.ASCII (AsciiString)-import Foundation.Collection  import Test.Tasty import Test.Tasty.QuickCheck

@@ -142,10 +142,10 @@                   => Proxy a -> Proxy b -> Proxy col -> Gen (Element a) -> Gen (Element b) -> [TestTree] testBoxedZippable proxyA proxyB proxyCol genElementA genElementB =     [ testProperty "zip" $ withList2 $ \(as, bs) ->-        toListP proxyCol (zip (fromListP proxyA as) (fromListP proxyB bs)) == zip as bs+        toListP proxyCol (zip (fromListP proxyA as) (fromListP proxyB bs)) === zip as bs     , testProperty "zip . unzip == id" $ withListOfTuples $ \xs ->         let (as, bs) = unzip (fromListP proxyCol xs)-        in toListP proxyCol (zip (as `asProxyTypeOf` proxyA) (bs `asProxyTypeOf` proxyB)) == xs+        in toListP proxyCol (zip (as `asProxyTypeOf` proxyA) (bs `asProxyTypeOf` proxyB)) === xs     ]   where     withList2 = forAll ((,) <$> generateListOfElement genElementA <*> generateListOfElement genElementB)@@ -157,7 +157,7 @@ testZippable proxyA proxyB proxyCol genElementA genElementB genElementCol =     [ testProperty "zipWith" $ withList2AndE $ \(as, bs, c) ->         toListP proxyCol (zipWith (const (const c)) (fromListP proxyA as) (fromListP proxyB bs)-            ) == Prelude.replicate (Prelude.min (length as) (length bs)) c+            ) === Prelude.replicate (Prelude.min (length as) (length bs)) c     ]   where     withList2AndE = forAll ( (,,) <$> generateListOfElement genElementA <*> generateListOfElement genElementB@@ -167,43 +167,43 @@                   => Proxy a -> Proxy b -> Gen (Element a) -> Gen (Element b) -> [TestTree] testZippableProps proxyA proxyB genElementA genElementB =     [ testProperty "zipWith _|_ [] xs == []" $ withList $ \as ->-        toListP proxyA (zipWith undefined [] (fromListP proxyA as)) == []+        toListP proxyA (zipWith undefined [] (fromListP proxyA as)) === []     , testProperty "zipWith f a b == zipWith (flip f) b a" $ withList2 $ \(as, bs) ->         let f = ignore1             as' = fromListP proxyA as             bs' = fromListP proxyB bs         in toListP proxyB (zipWith f as' bs')-            == toListP proxyB (zipWith (flip f) bs' as')+            === toListP proxyB (zipWith (flip f) bs' as')     , testProperty "zipWith3 f [...] xs == zipWith id (zipWith f [...]) xs)" $ withList2 $ \(as, bs) ->         let f = ignore2             as' = fromListP proxyA as             bs' = fromListP proxyB bs         in toListP proxyB (zipWith3 f as' as' bs')-            == Prelude.zipWith id (zipWith f as as) bs+            === Prelude.zipWith id (zipWith f as as) bs     , testProperty "zipWith4 f [...] xs == zipWith id (zipWith3 f [...]) xs)" $ withList2 $ \(as, bs) ->         let f = ignore3             as' = fromListP proxyA as             bs' = fromListP proxyB bs         in toListP proxyB (zipWith4 f as' as' as' bs')-            == Prelude.zipWith id (zipWith3 f as as as) bs+            === Prelude.zipWith id (zipWith3 f as as as) bs     , testProperty "zipWith5 f [...] xs == zipWith id (zipWith4 f [...]) xs)" $ withList2 $ \(as, bs) ->         let f = ignore4             as' = fromListP proxyA as             bs' = fromListP proxyB bs         in toListP proxyB (zipWith5 f as' as' as' as' bs')-            == Prelude.zipWith id (zipWith4 f as as as as) bs+            === Prelude.zipWith id (zipWith4 f as as as as) bs     , testProperty "zipWith6 f [...] xs == zipWith id (zipWith5 f [...]) xs)" $ withList2 $ \(as, bs) ->         let f = ignore5             as' = fromListP proxyA as             bs' = fromListP proxyB bs         in toListP proxyB (zipWith6 f as' as' as' as' as' bs')-            == Prelude.zipWith id (zipWith5 f as as as as as) bs+            === Prelude.zipWith id (zipWith5 f as as as as as) bs     , testProperty "zipWith7 f [...] xs == zipWith id (zipWith6 f [...]) xs)" $ withList2 $ \(as, bs) ->         let f = ignore6             as' = fromListP proxyA as             bs' = fromListP proxyB bs         in toListP proxyB (zipWith7 f as' as' as' as' as' as' bs')-            == Prelude.zipWith id (zipWith6 f as as as as as as) bs+            === Prelude.zipWith id (zipWith6 f as as as as as as) bs     ]   where     -- ignore the first n arguments