foundation 0.0.10 → 0.0.11

raw patch · 81 files changed

+1903/−812 lines, 81 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• Foundation.hs +1/−2
• Foundation/Array.hs +0/−1
• Foundation/Array/Bitmap.hs +27/−16
• Foundation/Array/Boxed.hs +49/−19
• Foundation/Array/Chunked/Unboxed.hs +22/−8
• Foundation/Array/Unboxed.hs +161/−18
• Foundation/Array/Unboxed/Mutable.hs +10/−7
• Foundation/Boot/Builder.hs +8/−2
• Foundation/Check.hs +2/−4
• Foundation/Check/Arbitrary.hs +1/−1
• Foundation/Check/Config.hs +2/−2
• Foundation/Check/Main.hs +3/−4
• Foundation/Check/Print.hs +1/−2
• Foundation/Class/Storable.hs +3/−3
• Foundation/Collection.hs +1/−1
• Foundation/Collection/Buildable.hs +13/−6
• Foundation/Collection/Collection.hs +20/−22
• Foundation/Collection/Foldable.hs +35/−9
• Foundation/Collection/Indexed.hs +0/−1
• Foundation/Collection/Keyed.hs +0/−1
• Foundation/Collection/NonEmpty.hs +18/−0
• Foundation/Collection/Sequential.hs +11/−1
• Foundation/Collection/Zippable.hs +3/−3
• Foundation/Conduit.hs +7/−0
• Foundation/Foreign/MemoryMap/Posix.hsc +2/−2
• Foundation/Foreign/MemoryMap/Types.hs +1/−1
• Foundation/Hashing/FNV.hs +8/−10
• Foundation/Hashing/SipHash.hs +6/−6
• Foundation/IO/File.hs +1/−1
• Foundation/Internal/MonadTrans.hs +3/−2
• Foundation/List/DList.hs +0/−1
• Foundation/List/SList.hs +0/−4
• Foundation/Monad/Reader.hs +1/−1
• Foundation/Monad/State.hs +4/−2
• Foundation/Network/IPv4.hs +11/−13
• Foundation/Network/IPv6.hs +17/−22
• Foundation/Numerical.hs +0/−1
• Foundation/Numerical/Additive.hs +0/−1
• Foundation/Numerical/Multiplicative.hs +0/−1
• Foundation/Parser.hs +384/−286
• Foundation/Primitive.hs +0/−1
• Foundation/Primitive/Block.hs +11/−9
• Foundation/Primitive/Block/Base.hs +9/−0
• Foundation/Primitive/Types.hs +1/−1
• Foundation/Primitive/Types/OffsetSize.hs +8/−0
• Foundation/Primitive/UTF8/Addr.hs +155/−0
• Foundation/Primitive/UTF8/BA.hs +155/−0
• Foundation/Primitive/UTF8/Base.hs +40/−76
• Foundation/Primitive/UTF8/Helper.hs +60/−31
• Foundation/Primitive/UTF8/Table.hs +0/−1
• Foundation/String.hs +2/−0
• Foundation/String/Builder.hs +57/−0
• Foundation/String/Encoding/ASCII7.hs +1/−1
• Foundation/String/Encoding/Encoding.hs +5/−5
• 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/UTF8.hs +108/−107
• Foundation/String/UTF8/Addr.hs +86/−0
• Foundation/String/UTF8/BA.hs +86/−0
• Foundation/System/Bindings/Time.hsc +37/−8
• Foundation/Time/StopWatch.hs +2/−3
• Foundation/Timing.hs +0/−1
• README.md +7/−7
• benchs/Fake/Text.hs +2/−0
• benchs/Main.hs +23/−2
• cbits/foundation_time.c +55/−14
• foundation.cabal +7/−1
• tests/Checks.hs +6/−6
• tests/Test/Checks/Property/Collection.hs +1/−1
• tests/Test/Foundation/Collection.hs +1/−1
• tests/Test/Foundation/Encoding.hs +2/−2
• tests/Test/Foundation/Misc.hs +1/−1
• tests/Test/Foundation/Number.hs +0/−1
• tests/Test/Foundation/Parser.hs +28/−23
• tests/Test/Foundation/Random.hs +1/−1
• tests/Test/Foundation/String.hs +83/−13
• tests/Test/Utils/Foreign.hs +2/−2
• tests/Tests.hs +2/−2

@@ -1,3 +1,22 @@+## 0.0.11++* Add Hlint support (configuration file), and default travis job+* Property report error through with the ASCII, UTF16, UTF32 string decoders+* Fix issue with OSX < Sierra+* Improve Parser and fix backtracking issue+* Strictify UArray to contains a strict ByteArray#+* Improve any & all for most collection types+* Improve minimum & maximum for most collection types+* Add foldl1 & foldr1+* Add takeWhile & dropWhile+* Remove foldl+* Add basic String builder+* Add String replace function+* Add conduit sourceList+* Improve performance of String uncons, unsnoc, filter and fromBytes UTF8 (validate)+* Improve UArray filter+* Fix compilation issue on windows with `clock_gettime` which is not available though all possible compilation mode+ ## 0.0.10  * Cleanup collection APIs that take a lone Int (length, take, drop, splitAt, ..) to take a CountOf

@@ -146,7 +146,7 @@ import qualified Prelude --import           Prelude (Char, (.), Eq, Bool, IO) -import           Data.Monoid (Monoid (..))+import           Data.Monoid (Monoid (..), (<>)) import           Control.Applicative import qualified Control.Category import qualified Control.Monad@@ -185,7 +185,6 @@ import qualified System.Environment import qualified Data.List -import           Data.Monoid ((<>))  default (Prelude.Integer, Prelude.Double) 

@@ -10,7 +10,6 @@ -- Generally accessible in o(1) -- {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} module Foundation.Array     ( Array     , MArray

@@ -32,6 +32,7 @@ import           Foundation.Array.Unboxed (UArray) import qualified Foundation.Array.Unboxed as A import           Foundation.Array.Unboxed.Mutable (MUArray)+import           Foundation.Class.Bifunctor (first, second) import           Foundation.Primitive.Exception import           Foundation.Internal.Base import           Foundation.Primitive.Types.OffsetSize@@ -78,7 +79,6 @@     imap = map  instance C.Foldable Bitmap where-    foldl = foldl     foldr = foldr     foldl' = foldl'     foldr' = foldr'@@ -87,10 +87,11 @@     null = null     length = length     elem e = Data.List.elem e . toList-    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO can shortcircuit all this massively-    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO DITTO-    all p = Data.List.all p . toList-    any p = Data.List.any p . toList+    maximum = any id . C.getNonEmpty+    minimum = all id . C.getNonEmpty+    all = all+    any = any+ instance C.Sequential Bitmap where     take = take     drop = drop@@ -289,7 +290,7 @@      toPacked :: [Bool] -> Word32     toPacked l =-        C.foldl (.|.) 0 $ Prelude.zipWith (\b w -> if b then (1 `shiftL` w) else 0) l (C.reverse [0..31])+        C.foldl' (.|.) 0 $ Prelude.zipWith (\b w -> if b then (1 `shiftL` w) else 0) l (C.reverse [0..31]) -}     len        = C.length allBools @@ -388,11 +389,11 @@  -- unoptimised uncons :: Bitmap -> Maybe (Bool, Bitmap)-uncons b = fmap (\(v, l) -> (v, fromList l)) $ C.uncons $ toList b+uncons b = fmap (second fromList) $ C.uncons $ toList b  -- unoptimised unsnoc :: Bitmap -> Maybe (Bitmap, Bool)-unsnoc b = fmap (\(l, v) -> (fromList l, v)) $ C.unsnoc $ toList b+unsnoc b = fmap (first fromList) $ C.unsnoc $ toList b  intersperse :: Bool -> Bitmap -> Bitmap intersperse b = unoptimised (C.intersperse b)@@ -416,14 +417,6 @@ reverse :: Bitmap -> Bitmap reverse bits = unoptimised C.reverse bits -foldl :: (a -> Bool -> a) -> a -> Bitmap -> a-foldl f initialAcc vec = loop 0 initialAcc-  where-    len = length vec-    loop i acc-        | 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@@ -442,6 +435,24 @@     loop i !acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))++all :: (Bool -> Bool) -> Bitmap -> Bool+all p bm = loop 0+  where+    len = length bm+    loop !i+      | i .==# len = True+      | not $ p (unsafeIndex bm i) = False+      | otherwise = loop (i + 1)++any :: (Bool -> Bool) -> Bitmap -> Bool+any p bm = loop 0+  where+    len = length bm+    loop !i+      | i .==# len = False+      | p (unsafeIndex bm i) = True+      | otherwise = loop (i + 1)  unoptimised :: ([Bool] -> [Bool]) -> Bitmap -> Bitmap unoptimised f = vFromList . f . vToList

@@ -56,15 +56,20 @@     , find     , foldl'     , foldr-    , foldl+    , foldl1'+    , foldr1+    , all+    , any     , builderAppend     , builderBuild+    , builderBuild_     ) where  import           GHC.Prim import           GHC.Types import           GHC.ST import           Foundation.Numerical+import           Foundation.Collection.NonEmpty import           Foundation.Internal.Base import           Foundation.Internal.Proxy import           Foundation.Internal.MonadTrans@@ -635,14 +640,6 @@     len@(CountOf s) = length a     toEnd (Offset i) = unsafeIndex a (Offset (s - 1 - i)) -foldl :: (a -> ty -> a) -> a -> Array ty -> a-foldl f initialAcc vec = loop 0 initialAcc-  where-    len = length vec-    loop !i acc-        | 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@@ -659,8 +656,34 @@         | 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) ->+foldl1' :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty+foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr+               in foldl' f (unsafeIndex initialAcc 0) rest++foldr1 :: (ty -> ty -> ty) -> NonEmpty (Array ty) -> ty+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr+               in foldr f (unsafeIndex initialAcc 0) rest++all :: (ty -> Bool) -> Array ty -> Bool+all p ba = loop 0+  where+    len = length ba+    loop !i+      | i .==# len = True+      | not $ p (unsafeIndex ba i) = False+      | otherwise = loop (i + 1)++any :: (ty -> Bool) -> Array ty -> Bool+any p ba = loop 0+  where+    len = length ba+    loop !i+      | i .==# len = False+      | p (unsafeIndex ba i) = True+      | otherwise = loop (i + 1)++builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err ()+builderAppend v = Builder $ State $ \(i, st, e) ->     if i .==# chunkSize st         then do             cur      <- unsafeFreeze (curChunk st)@@ -669,21 +692,25 @@             return ((), (Offset 1, st { prevChunks     = cur : prevChunks st                                       , prevChunksSize = chunkSize st + prevChunksSize st                                       , curChunk       = newChunk-                                      }))+                                      }, e))         else do             unsafeWrite (curChunk st) i v-            return ((), (i+1, st))+            return ((), (i+1, st, e)) -builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () -> m (Array ty)+builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty)) builderBuild sizeChunksI ab     | sizeChunksI <= 0 = builderBuild 64 ab     | otherwise        = do         first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks)-        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)-        -- Build final array-        let totalSize = prevChunksSize st + offsetAsSize i-        new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+        ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing)+        case e of+          Just err -> return (Left err)+          Nothing -> do+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            -- Build final array+            let totalSize = prevChunksSize st + offsetAsSize i+            bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+            return (Right bytes)   where     sizeChunks = CountOf sizeChunksI @@ -692,3 +719,6 @@         let sz = length x         unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz         fillFromEnd (end - sz) xs mua++builderBuild_ :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () () -> m (Array ty)+builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab

@@ -8,7 +8,6 @@ -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -55,14 +54,19 @@     fromList = vFromList     toList = vToList +instance PrimType ty => C.Foldable (ChunkedUArray ty) where+    foldl' = foldl'+    foldr = foldr+    -- Use the default foldr' instance+ instance PrimType ty => C.Collection (ChunkedUArray ty) where     null = null     length = length     elem   = elem     minimum = minimum     maximum = maximum-    all p = Data.List.all p . toList-    any p = Data.List.any p . toList+    all p (ChunkedUArray cua) = A.all (U.all p) cua+    any p (ChunkedUArray cua) = A.any (U.any p) cua  instance PrimType ty => C.Sequential (ChunkedUArray ty) where     take = take@@ -97,7 +101,7 @@                 if predicate (unsafeIndex c i) then Just i else Nothing  empty :: ChunkedUArray ty-empty = ChunkedUArray (A.empty)+empty = ChunkedUArray A.empty  append :: ChunkedUArray ty -> ChunkedUArray ty -> ChunkedUArray ty append (ChunkedUArray a1) (ChunkedUArray a2) = ChunkedUArray (mappend a1 a2)@@ -138,13 +142,23 @@                 True  -> True                 False -> loop (i+1) --- | TODO: Improve implementation.+-- | Fold a `ChunkedUArray' leftwards strictly. Implemented internally using a double+-- fold on the nested Array structure. Other folds implemented analogously.+foldl' :: PrimType ty => (a -> ty -> a) -> a -> ChunkedUArray ty -> a+foldl' f initialAcc (ChunkedUArray cua) = A.foldl' (U.foldl' f) initialAcc cua++foldr :: PrimType ty => (ty -> a -> a) -> a -> ChunkedUArray ty -> a+foldr f initialAcc (ChunkedUArray cua) = A.foldr (flip $ U.foldr f) initialAcc cua+ minimum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty-minimum = Data.List.minimum . toList . C.getNonEmpty+minimum cua = foldl' min (unsafeIndex cua' 0) (drop 1 cua')+  where+    cua' = C.getNonEmpty cua --- | TODO: Improve implementation. maximum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty-maximum = Data.List.maximum . toList . C.getNonEmpty+maximum cua = foldl' max (unsafeIndex cua' 0) (drop 1 cua')+  where+    cua' = C.getNonEmpty cua  -- | Equality between `ChunkedUArray`. -- This function is fiddly to write as is not enough to compare for

@@ -12,7 +12,6 @@ -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} module Foundation.Array.Unboxed@@ -63,6 +62,7 @@     , take     , unsafeTake     , drop+    , unsafeDrop     , splitAt     , revDrop     , revTake@@ -72,6 +72,7 @@     , break     , breakElem     , elem+    , indices     , intersperse     , span     , cons@@ -82,13 +83,18 @@     , sortBy     , filter     , reverse-    , foldl+    , replace     , foldr     , foldl'+    , foldr1+    , foldl1'+    , all+    , any     , foreignMem     , fromForeignPtr     , builderAppend     , builderBuild+    , builderBuild_     , toHexadecimal     ) where @@ -107,6 +113,7 @@ import           Foundation.Internal.Proxy import           Foundation.Primitive.Types.OffsetSize import           Foundation.Internal.MonadTrans+import           Foundation.Collection.NonEmpty import qualified Foundation.Primitive.Base16 as Base16 import           Foundation.Primitive.Monad import           Foundation.Primitive.Types@@ -129,7 +136,7 @@       UVecBA {-# UNPACK #-} !(Offset ty)              {-# UNPACK #-} !(CountOf ty)              {-# UNPACK #-} !PinnedStatus {- unpinned / pinned flag -}-                            ByteArray#+                            !ByteArray#     | UVecAddr {-# UNPACK #-} !(Offset ty)                {-# UNPACK #-} !(CountOf ty)                               !(FinalPtr ty)@@ -145,7 +152,7 @@  instance NormalForm (UArray ty) where     toNormalForm (UVecBA _ _ _ !_) = ()-    toNormalForm (UVecAddr _ _ _) = ()+    toNormalForm (UVecAddr {}) = () instance (PrimType ty, Show ty) => Show (UArray ty) where     show v = show (toList v) instance (PrimType ty, Eq ty) => Eq (UArray ty) where@@ -720,6 +727,10 @@   where     vlen = length v +unsafeDrop :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+unsafeDrop n (UVecBA start sz pinst ba) = UVecBA (start `offsetPlusE` sz) (sz `sizeSub` n) pinst ba+unsafeDrop n (UVecAddr start sz fptr)   = UVecAddr (start `offsetPlusE` sz) (sz `sizeSub` n) fptr+ -- | Split an array into two, with a count of at most N elements in the first one -- and the remaining in the other. splitAt :: PrimType ty => CountOf ty -> UArray ty -> (UArray ty, UArray ty)@@ -997,14 +1008,43 @@             unsafeWrite ma i ahi             return i -filter :: PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty-filter predicate vec = vFromList $ Data.List.filter predicate $ vToList vec+filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty+filter predicate arr = runST $ do+    (newLen, ma) <- newNative (length arr) $ \mba ->+                case arr of+                    (UVecAddr start _ fptr) -> withFinalPtr fptr (goAddr mba start)+                    (UVecBA start _ _ ba)   -> goBA mba ba start+    unsafeFreezeShrink ma newLen+  where+    !len = length arr+    o1 = Offset 1 +    goBA :: PrimType ty => MutableByteArray# s -> ByteArray# -> Offset ty -> ST s (CountOf ty)+    goBA dst src start = loop azero start+      where+        end = start `offsetPlusE` len+        loop !d !s+            | s == end    = pure (offsetAsSize d)+            | predicate v = primMbaWrite dst d v >> loop (d+o1) (s+o1)+            | otherwise   = loop d (s+o1)+          where+            v = primBaIndex src s+    goAddr :: PrimType ty => MutableByteArray# s -> Offset ty -> (Ptr addr) -> ST s (CountOf ty)+    goAddr dst start (Ptr addr) = loop azero start+      where+        end = start `offsetPlusE` len+        loop !d !s+            | s == end    = pure (offsetAsSize d)+            | predicate v = primMbaWrite dst d v >> loop (d+o1) (s+o1)+            | otherwise   = loop d (s+o1)+          where+            v = primAddrIndex addr s+ reverse :: PrimType ty => UArray ty -> UArray ty reverse a     | len == CountOf 0 = empty     | otherwise     = runST $ do-        ma <- newNative len $ \mba ->+        ((), ma) <- newNative len $ \mba ->                 case a of                     (UVecBA start _ _ ba)   -> goNative endOfs mba ba start                     (UVecAddr start _ fptr) -> withFinalPtr fptr $ \ptr -> goAddr endOfs mba ptr start@@ -1020,7 +1060,7 @@         loop !i             | i == end  = return ()             | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+Offset 1)-    goAddr !end !ma !(Ptr ba) !srcStart = loop (Offset 0)+    goAddr !end !ma (Ptr ba) !srcStart = loop (Offset 0)       where         !endI = sizeAsOffset ((srcStart + end) - Offset 1)         loop !i@@ -1028,6 +1068,76 @@             | otherwise = primMbaWrite ma i (primAddrIndex ba (sizeAsOffset (endI - i))) >> loop (i+Offset 1) {-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-} +-- Finds where are the insertion points when we search for a `needle`+-- within an `haystack`.+-- Throws an error in case `needle` is empty.+indices :: PrimType ty => UArray ty -> UArray ty -> [Offset ty]+indices needle hy+  | needleLen <= 0 = error "Foundation.Array.Unboxed.indices: needle is empty."+  | otherwise = case haystackLen < needleLen of+                  True  -> []+                  False -> go (Offset 0) []+  where+    !haystackLen = length hy++    !needleLen = length needle++    go currentOffset ipoints+      | (currentOffset `offsetPlusE` needleLen) > (sizeAsOffset haystackLen) = ipoints+      | otherwise =+        let matcher = take needleLen . drop (offsetAsSize currentOffset) $ hy+        in case matcher == needle of+             -- TODO: Move away from right-appending as it's gonna be slow.+             True  -> go (currentOffset `offsetPlusE` needleLen) (ipoints <> [currentOffset])+             False -> go (currentOffset + Offset 1) ipoints++-- | Replace all the occurrencies of `needle` with `replacement` in+-- the `haystack` string.+replace :: PrimType ty => UArray ty -> UArray ty -> UArray ty -> UArray ty+replace (needle :: UArray ty) replacement haystack = runST $ do+    case null needle of+      True -> error "Foundation.Array.Unboxed.replace: empty needle"+      False -> do+        let insertionPoints = indices needle haystack+        let !occs           = Prelude.length insertionPoints+        let !newLen         = haystackLen - (multBy needleLen occs) + (multBy replacementLen occs)+        ms <- new newLen+        loop ms (Offset 0) (Offset 0) insertionPoints+  where++    multBy (CountOf x) y = CountOf (x * y)++    !needleLen = length needle++    !replacementLen = length replacement++    !haystackLen = length haystack++    -- Go through each insertion point and copy things over.+    -- We keep around the offset to the original string to+    -- be able to copy bytes which didn't change.+    loop :: PrimMonad prim+         => MUArray ty (PrimState prim)+         -> Offset ty+         -> Offset ty+         -> [Offset ty]+         -> prim (UArray ty)+    loop mba currentOffset offsetInOriginalString [] = do+      -- Finalise the string+      let !unchangedDataLen = sizeAsOffset haystackLen - offsetInOriginalString+      unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen+      freeze mba+    loop mba currentOffset offsetInOriginalString (x:xs) = do+        -- 1. Copy from the old string.+        let !unchangedDataLen = (x - offsetInOriginalString)+        unsafeCopyAtRO mba currentOffset haystack offsetInOriginalString unchangedDataLen+        let !newOffset = currentOffset `offsetPlusE` unchangedDataLen+        -- 2. Copy the replacement.+        unsafeCopyAtRO mba newOffset replacement (Offset 0) replacementLen+        let !offsetInOriginalString' = offsetInOriginalString `offsetPlusE` unchangedDataLen `offsetPlusE` needleLen+        loop mba (newOffset `offsetPlusE` replacementLen) offsetInOriginalString' xs+{-# SPECIALIZE [3] replace :: UArray Word8 -> UArray Word8 -> UArray Word8 -> UArray Word8 #-}+ foldl :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a foldl f initialAcc vec = loop 0 initialAcc   where@@ -1052,8 +1162,34 @@         | 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) ->+foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty+foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr+               in foldl' f (unsafeIndex initialAcc 0) rest++foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr+               in foldr f (unsafeIndex initialAcc 0) rest++all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool+all p uv = loop 0+  where+    len = length uv+    loop !i+      | i .==# len = True+      | not $ p (unsafeIndex uv i) = False+      | otherwise = loop (i + 1)++any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool+any p uv = loop 0+  where+    len = length uv+    loop !i+      | i .==# len = False+      | p (unsafeIndex uv i) = True+      | otherwise = loop (i + 1)++builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err ()+builderAppend v = Builder $ State $ \(i, st, e) ->     if offsetAsSize i == chunkSize st         then do             cur      <- unsafeFreeze (curChunk st)@@ -1062,21 +1198,25 @@             return ((), (Offset 1, st { prevChunks     = cur : prevChunks st                                       , prevChunksSize = chunkSize st + prevChunksSize st                                       , curChunk       = newChunk-                                      }))+                                      }, e))         else do             unsafeWrite (curChunk st) i v-            return ((), (i + 1, st))+            return ((), (i + 1, st, e)) -builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () -> m (UArray ty)+builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty)) builderBuild sizeChunksI ab     | sizeChunksI <= 0 = builderBuild 64 ab     | otherwise        = do         first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks)-        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)-        -- Build final array-        let totalSize = prevChunksSize st + offsetAsSize i-        new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+        ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing)+        case e of+          Just err -> return (Left err)+          Nothing -> do+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            -- Build final array+            let totalSize = prevChunksSize st + offsetAsSize i+            bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+            return (Right bytes)   where       sizeChunks = CountOf sizeChunksI @@ -1085,6 +1225,9 @@           let sz = length x           unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz           fillFromEnd (end - sz) xs mua++builderBuild_ :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () () -> m (UArray ty)+builderBuild_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI ab  toHexadecimal :: PrimType ty => UArray ty -> UArray Word8 toHexadecimal ba

@@ -161,18 +161,21 @@ {-# INLINE new #-}  mutableSame :: MUArray ty st -> MUArray ty st -> Bool-mutableSame (MUVecMA sa ea _ ma) (MUVecMA sb eb _ mb) = and [ sa == sb, ea == eb, bool# (sameMutableByteArray# ma mb)]-mutableSame (MUVecAddr s1 e1 f1) (MUVecAddr s2 e2 f2) = and [ s1 == s2, e1 == e2, finalPtrSameMemory f1 f2 ]-mutableSame (MUVecMA {})     (MUVecAddr {})   = False-mutableSame (MUVecAddr {})   (MUVecMA {})     = False+mutableSame (MUVecMA sa ea _ ma) (MUVecMA sb eb _ mb) = (sa == sb) && (ea == eb) && bool# (sameMutableByteArray# ma mb)+mutableSame (MUVecAddr s1 e1 f1) (MUVecAddr s2 e2 f2) = (s1 == s2) && (e1 == e2) && finalPtrSameMemory f1 f2+mutableSame MUVecMA {}     MUVecAddr {}   = False+mutableSame MUVecAddr {}   MUVecMA {}     = False  -newNative :: (PrimMonad prim, PrimType ty) => CountOf ty -> (MutableByteArray# (PrimState prim) -> prim ()) -> prim (MUArray ty (PrimState prim))+newNative :: (PrimMonad prim, PrimType ty)+          => CountOf ty+          -> (MutableByteArray# (PrimState prim) -> prim a)+          -> prim (a, MUArray ty (PrimState prim)) newNative n f = do     muvec <- new n     case muvec of-        (MUVecMA _ _ _ mba) -> f mba >> return muvec-        (MUVecAddr {})      -> error "internal error: unboxed new only supposed to allocate natively"+        (MUVecMA _ _ _ mba) -> f mba >>= \a -> pure (a, muvec)+        MUVecAddr {}        -> error "internal error: unboxed new only supposed to allocate natively"  mutableForeignMem :: (PrimMonad prim, PrimType ty)                   => FinalPtr ty -- ^ the start pointer with a finalizer

@@ -6,11 +6,12 @@  import           Foundation.Internal.Base import           Foundation.Internal.MonadTrans+import           Foundation.Monad.Exception import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad -newtype Builder collection mutCollection step state a = Builder-    { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state)) state a }+newtype Builder collection mutCollection step state err a = Builder+  { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a }     deriving (Functor, Applicative, Monad)  -- | The in-progress state of a building operation.@@ -24,3 +25,8 @@     , curChunk       :: mutCollection state     , chunkSize      :: !(CountOf step)     }++instance Monad state => MonadFailure (Builder collection mutCollection step state err) where+  type Failure (Builder collection mutCollection step state err) = err+  mFail builderError = Builder $ State $ \(offset, bs, _)  ->+    return ((), (offset, bs, Just builderError))

@@ -10,8 +10,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Check     ( Gen     , Arbitrary(..)@@ -66,7 +64,7 @@ pick :: String -> IO a -> Check a pick _ io = Check $ do     -- TODO catch most exception to report failures-    r <- liftIO $ io+    r <- liftIO io     pure r  iterateProperty :: CountOf TestResult ->  GenParams -> (Word64 -> GenRng) -> Property -> IO (PropertyResult, CountOf TestResult)@@ -75,7 +73,7 @@     iterProp !iter       | iter == limit = return (PropertySuccess, iter)       | otherwise  = do-          r <- liftIO $ toResult+          r <- liftIO toResult           case r of               (PropertyFailed e, _)               -> return (PropertyFailed e, iter)               (PropertySuccess, cont) | cont      -> iterProp (iter+1)

@@ -109,7 +109,7 @@         ]   where     integerOfSize :: Bool -> Word -> Gen Integer-    integerOfSize toSign n = ((if toSign then (\x -> 0 - x) else id) . foldl (\x y -> x + integralUpsize y) 0 . toList)+    integerOfSize toSign n = ((if toSign then negate else id) . foldl' (\x y -> x + integralUpsize y) 0 . toList)                          <$> (arbitraryUArrayOf n :: Gen (UArray Word8))  arbitraryNatural :: Gen Natural

@@ -71,9 +71,9 @@  parseArgs :: [String] -> Config -> Either ParamError Config parseArgs []                cfg   = Right cfg-parseArgs ("--seed":[])    _      = Left "option `--seed' is missing a parameter"+parseArgs ["--seed"]       _      = Left "option `--seed' is missing a parameter" parseArgs ("--seed":x:xs)  cfg    = getInteger "seed" x >>= \i -> parseArgs xs $ cfg { udfSeed = Just $ integralDownsize i }-parseArgs ("--tests":[])   _      = Left "option `--tests' is missing a parameter"+parseArgs ["--tests"]      _      = Left "option `--tests' is missing a parameter" parseArgs ("--tests":x:xs) cfg    = getInteger "tests" x >>= \i -> parseArgs xs $ cfg { numTests = integralDownsize i } parseArgs ("--quiet":xs)   cfg    = parseArgs xs $ cfg { displayOptions = DisplayTerminalErrorOnly } parseArgs ("--list-tests":xs) cfg = parseArgs xs $ cfg { listTests = True }

@@ -67,11 +67,11 @@     | null (testNameMatch cfg) = Just testRoot     | otherwise                = testFilter [] testRoot   where-    match acc s = or $ fmap (flip isInfixOf currentTestName) $ testNameMatch cfg+    match acc s = or (flip isInfixOf currentTestName <$> testNameMatch cfg)       where currentTestName = fqTestName (s:acc)     or [] = False     or (x:xs)-        | x == True = True+        | x         = True         | otherwise = or xs      testFilter acc x =@@ -177,8 +177,7 @@ test (Group s l) = pushGroup s l test (Unit _ _) = undefined test (CheckPlan name plan) = do-    r <- testCheckPlan name plan-    return r+    testCheckPlan name plan test (Property name prop) = do     r'@(PropertyResult _ nb r) <- testProperty name (property prop)     case r of

@@ -2,7 +2,6 @@ {-# LANGUAGE Rank2Types                 #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE FlexibleContexts           #-} module Foundation.Check.Print@@ -24,7 +23,7 @@             checks = getChecks propertyTestArg          in if checkHasFailed checks                 then printError args checks-                else (PropertySuccess, length args > 0)+                else (PropertySuccess, not (null args))   where     printError args checks = (PropertyFailed (mconcat $ loop 1 args), False)       where

@@ -40,7 +40,7 @@ import Foundation.Internal.Base import Foundation.Primitive.Types.OffsetSize import Foundation.Collection-import Foundation.Collection.Buildable (builderLift)+import Foundation.Collection.Buildable (builderLift, build_) import Foundation.Primitive.Types import Foundation.Primitive.Endianness import Foundation.Numerical@@ -73,7 +73,7 @@  peekArray :: (Buildable col, StorableFixed (Element col))           => CountOf (Element col) -> Ptr (Element col) -> IO col-peekArray (CountOf s) = build 64 . builder 0+peekArray (CountOf s) p = build_ 64 . builder 0 $ p   where     builder off ptr       | off == s = return ()@@ -84,7 +84,7 @@  peekArrayEndedBy :: (Buildable col, StorableFixed (Element col), Eq (Element col), Show (Element col))                  => Element col -> Ptr (Element col) -> IO col-peekArrayEndedBy term = build 64 . builder 0+peekArrayEndedBy term p = build_ 64 . builder 0 $ p   where     builder off ptr = do       v <- builderLift $ peekOff ptr off

@@ -8,7 +8,6 @@ -- Different collections (list, vector, string, ..) unified under 1 API. -- an API to rules them all, and in the darkness bind them. ---{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Collection     ( BoxedZippable(..)@@ -32,6 +31,7 @@     , KeyedCollection(..)     , Zippable(..)     , Buildable(..)+    , build_     , Builder(..)     , BuildingState(..)     , Copy(..)

@@ -12,6 +12,7 @@     , Builder(..)     , BuildingState(..)     , builderLift+    , build_     ) where  import           Foundation.Array.Unboxed@@ -49,19 +50,25 @@     -- should be defined as 1 byte for collections of `Char`.     type Step col -    append :: (PrimMonad prim) => Element col -> Builder col (Mutable col) (Step col) prim ()+    append :: (PrimMonad prim) => Element col -> Builder col (Mutable col) (Step col) prim err ()      build :: (PrimMonad prim)           => Int -- ^ CountOf of a chunk-          -> Builder col (Mutable col) (Step col) prim ()-          -> prim col+          -> Builder col (Mutable col) (Step col) prim err ()+          -> prim (Either err col)  builderLift :: (Buildable c, PrimMonad prim)             => prim a-            -> Builder c (Mutable c) (Step c) prim a-builderLift f = Builder $ State $ \(i, st) -> do+            -> Builder c (Mutable c) (Step c) prim err a+builderLift f = Builder $ State $ \(i, st, e) -> do     ret <- f-    return (ret, (i, st))+    return (ret, (i, st, e))++build_ :: (Buildable c, PrimMonad prim)+       => Int -- ^ CountOf of a chunk+       -> Builder c (Mutable c) (Step c) prim () ()+       -> prim c+build_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> build sizeChunksI ab  instance PrimType ty => Buildable (UArray ty) where     type Mutable (UArray ty) = MUArray ty

@@ -31,18 +31,13 @@ import           Foundation.Internal.Base import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection.Element+import           Foundation.Collection.NonEmpty import qualified Data.List import qualified Foundation.Primitive.Block as BLK import qualified Foundation.Array.Unboxed as UV import qualified Foundation.Array.Boxed as BA import qualified Foundation.String.UTF8 as S --- | NonEmpty property for any Collection------ This can only be made, through the 'nonEmpty' smart contructor-newtype NonEmpty a = NonEmpty { getNonEmpty :: a }-    deriving (Show,Eq)- -- | Smart constructor to create a NonEmpty collection -- -- If the collection is empty, then Nothing is returned@@ -117,28 +112,31 @@     null = (==) 0 . BLK.length     length = BLK.length     elem = BLK.elem-    minimum = Data.List.minimum . toList . getNonEmpty-    maximum = Data.List.maximum . toList . getNonEmpty+    minimum = BLK.foldl1' min+    maximum = BLK.foldl1' max     all = BLK.all     any = BLK.any  instance UV.PrimType ty => Collection (UV.UArray ty) where-    null = UV.null-    length = UV.length-    elem = UV.elem-    minimum = Data.List.minimum . toList . getNonEmpty-    maximum = Data.List.maximum . toList . getNonEmpty-    all p = Data.List.all p . toList-    any p = Data.List.any p . toList+    null    = UV.null+    length  = UV.length+    elem    = UV.elem+    minimum = UV.foldl1' min+    maximum = UV.foldl1' max+    all     = UV.all+    any     = UV.any + instance Collection (BA.Array ty) where-    null = BA.null-    length = BA.length-    elem = BA.elem-    minimum = Data.List.minimum . toList . getNonEmpty -- TODO-    maximum = Data.List.maximum . toList . getNonEmpty -- TODO-    all p = Data.List.all p . toList-    any p = Data.List.any p . toList+    null    = BA.null+    length  = BA.length+    elem    = BA.elem+    minimum = BA.foldl1' min+    maximum = BA.foldl1' max+    all     = BA.all+    any     = BA.any++  instance Collection S.String where     null = S.null

@@ -9,10 +9,12 @@ -- module Foundation.Collection.Foldable     ( Foldable(..)+    , Fold1able(..)     ) where  import           Foundation.Internal.Base import           Foundation.Collection.Element+import           Foundation.Collection.NonEmpty import qualified Data.List import qualified Foundation.Array.Unboxed as UV import qualified Foundation.Primitive.Block as BLK@@ -27,11 +29,10 @@     -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn     -- Note that to produce the outermost application of the operator the entire input list must be traversed. This means that foldl' will diverge if given an infinite list.     ---    -- Also note that if you want an efficient left-fold, you probably want to use foldl' instead of foldl. The reason for this is that latter does not force the "inner" results (e.g. z f x1 in the above example) before applying them to the operator (e.g. to (f x2)). This results in a thunk chain O(n) elements long, which then must be evaluated from the outside-in.-    foldl :: (a -> Element collection -> a) -> a -> collection -> a-+    -- Note that Foundation only provides `foldl'`, a strict version of `foldl` because+    -- the lazy version is seldom useful. -    -- | Left-associative fold of a structure but with strict application of the operator.+    -- | Left-associative fold of a structure with strict application of the operator.     foldl' :: (a -> Element collection -> a) -> a -> collection -> a      -- | Right-associative fold of a structure.@@ -41,26 +42,51 @@      -- | Right-associative fold of a structure, but with strict application of the operator.     foldr' :: (Element collection -> a -> a) -> a -> collection -> a-    foldr' f z0 xs = foldl f' id xs z0 where f' k x z = k $! f x z+    foldr' f z0 xs = foldl' f' id xs z0 where f' k x z = k $! f x z +-- | Fold1's. Like folds, but they assume to operate on a NonEmpty collection.+class Foldable f => Fold1able f where+    -- | Left associative strict fold.+    foldl1' :: (Element f -> Element f -> Element f) -> NonEmpty f -> Element f+    -- | Right associative lazy fold.+    foldr1  :: (Element f -> Element f -> Element f) -> NonEmpty f -> Element f+    -- | Right associative strict fold.+    --foldr1' :: (Element f -> Element f -> Element f) -> NonEmpty f -> Element f+    --foldr1' f xs = foldl f' id . getNonEmpty+    --  where f' k x z = k $! f x z++ ---------------------------- -- Foldable instances ----------------------------  instance Foldable [a] where-    foldl = Data.List.foldl     foldr = Data.List.foldr     foldl' = Data.List.foldl'  instance UV.PrimType ty => Foldable (UV.UArray ty) where-    foldl = UV.foldl     foldr = UV.foldr     foldl' = UV.foldl' instance Foldable (BA.Array ty) where-    foldl = BA.foldl     foldr = BA.foldr     foldl' = BA.foldl' instance UV.PrimType ty => Foldable (BLK.Block ty) where-    foldl = BLK.foldl     foldr = BLK.foldr     foldl' = BLK.foldl'++----------------------------+-- Fold1able instances+----------------------------+instance Fold1able [a] where+  foldr1 f  = Data.List.foldr1 f . getNonEmpty+  foldl1' f = Data.List.foldl1' f . getNonEmpty++instance UV.PrimType ty => Fold1able (UV.UArray ty) where+    foldr1 = UV.foldr1+    foldl1' = UV.foldl1'+instance Fold1able (BA.Array ty) where+    foldr1  = BA.foldr1+    foldl1' = BA.foldl1'+instance UV.PrimType ty => Fold1able (BLK.Block ty) where+    foldr1  = BLK.foldr1+    foldl1' = BLK.foldl1'

@@ -5,7 +5,6 @@ -- Stability   : experimental -- Portability : portable ---{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Collection.Indexed     ( IndexedCollection(..)

@@ -5,7 +5,6 @@ -- Stability   : experimental -- Portability : portable ---{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Collection.Keyed     ( KeyedCollection(..)

@@ -0,0 +1,18 @@+-- |+-- Module      : Foundation.Collection.NonEmpty+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--+-- A newtype wrapper around a non-empty Collection.++module Foundation.Collection.NonEmpty+    ( NonEmpty(..)+    ) where++import Foundation.Internal.Base++-- | NonEmpty property for any Collection+newtype NonEmpty a = NonEmpty { getNonEmpty :: a }+    deriving (Show,Eq)

@@ -76,6 +76,14 @@     breakElem :: Eq (Element c) => Element c -> c -> (c,c)     breakElem c = break (== c) +    -- | Return the longest prefix in the collection that satisfy the predicate+    takeWhile :: (Element c -> Bool) -> c -> c+    takeWhile predicate = fst . span predicate++    -- | Return the longest prefix in the collection that satisfy the predicate+    dropWhile :: (Element c -> Bool) -> c -> c+    dropWhile predicate = snd . span predicate+     -- | The 'intersperse' function takes an element and a list and     -- \`intersperses\' that element between the elements of the list.     -- For example,@@ -182,7 +190,7 @@             | i == endofs = c1 == c2Sub             | c1 == c2Sub = True             | otherwise   = loop (succ i)-          where c2Sub = take len1 $ drop i $ c2+          where c2Sub = take len1 $ drop i c2  -- Temporary utility functions mconcatCollection :: (Monoid (Item c), Sequential c) => c -> Element c@@ -199,6 +207,8 @@     break = Data.List.break     intersperse = Data.List.intersperse     span = Data.List.span+    dropWhile = Data.List.dropWhile+    takeWhile = Data.List.takeWhile     filter = Data.List.filter     partition = Data.List.partition     reverse = Data.List.reverse

@@ -77,21 +77,21 @@ instance Zippable [c]  instance UV.PrimType ty => Zippable (UV.UArray ty) where-  zipWith f as bs = runST $ UV.builderBuild 64 $ go f (toList as) (toList bs)+  zipWith f as bs = runST $ UV.builderBuild_ 64 $ go f (toList as) (toList bs)     where       go _  []       _        = return ()       go _  _        []       = return ()       go f' (a':as') (b':bs') = UV.builderAppend (f' a' b') >> go f' as' bs'  instance Zippable (BA.Array ty) where-  zipWith f as bs = runST $ BA.builderBuild 64 $ go f (toList as) (toList bs)+  zipWith f as bs = runST $ BA.builderBuild_ 64 $ go f (toList as) (toList bs)     where       go _  []       _        = return ()       go _  _        []       = return ()       go f' (a':as') (b':bs') = BA.builderAppend (f' a' b') >> go f' as' bs'  instance Zippable S.String where-  zipWith f as bs = runST $ S.builderBuild 64 $ go f (toList as) (toList bs)+  zipWith f as bs = runST $ S.builderBuild_ 64 $ go f (toList as) (toList bs)     where       go _  []       _        = return ()       go _  _        []       = return ()

@@ -5,6 +5,7 @@     , await     , awaitForever     , yield+    , yields     , yieldOr     , leftover     , runConduit@@ -56,6 +57,12 @@         if null arr             then return ()             else yield arr >> loop++-- | Send values downstream.+yields :: (Monad m, Foldable os, Element os ~ o) => os -> Conduit i o m ()+-- FIXME: Should be using mapM_ once that is in Foldable, see #334+yields = foldr ((>>) . yield) (return ())+  sinkFile :: MonadResource m => FilePath -> Conduit (UArray Word8) i m () sinkFile fp = bracketConduit

@@ -131,7 +131,7 @@     deriving (Show,Eq)  cvalueOfMemoryProts :: [MemoryProtection] -> CInt-cvalueOfMemoryProts = foldl (.|.) 0 . fmap toProt+cvalueOfMemoryProts = foldl' (.|.) 0 . fmap toProt   where toProt :: MemoryProtection -> CInt         toProt MemoryProtectionNone    = (#const PROT_NONE)         toProt MemoryProtectionRead    = (#const PROT_READ)@@ -139,7 +139,7 @@         toProt MemoryProtectionExecute = (#const PROT_EXEC)  cvalueOfMemorySync :: [MemorySyncFlag] -> CInt-cvalueOfMemorySync = foldl (.|.) 0 . fmap toSync+cvalueOfMemorySync = foldl' (.|.) 0 . fmap toSync   where toSync MemorySyncAsync      = (#const MS_ASYNC)         toSync MemorySyncSync       = (#const MS_SYNC)         toSync MemorySyncInvalidate = (#const MS_INVALIDATE)

@@ -29,6 +29,6 @@ -- unmap memory when the pointer is garbage. fileMappingToFinalPtr :: FileMapping -> IO (FinalPtr Word8) fileMappingToFinalPtr (FileMapping ptr _ finalizer) =-    toFinalPtr ptr (\_ -> finalizer)+    toFinalPtr ptr (const finalizer)  type FileMapReadF = FilePath -> IO FileMapping

@@ -8,9 +8,7 @@ -- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions) -- <http://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function> ---{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE UnboxedTuples              #-} {-# LANGUAGE BangPatterns               #-} module Foundation.Hashing.FNV     (@@ -63,19 +61,19 @@ newtype FNV1a_64 = FNV1a_64 Word64  fnv1_32_Mix8 :: Word8 -> FNV1_32 -> FNV1_32-fnv1_32_Mix8 !w !(FNV1_32 acc) = FNV1_32 (0x01000193 * acc `xor32` w)+fnv1_32_Mix8 !w (FNV1_32 acc) = FNV1_32 (0x01000193 * acc `xor32` w) {-# INLINE fnv1_32_Mix8 #-}  fnv1a_32_Mix8 :: Word8 -> FNV1a_32 -> FNV1a_32-fnv1a_32_Mix8 !w !(FNV1a_32 acc) = FNV1a_32 (0x01000193 * (acc `xor32` w))+fnv1a_32_Mix8 !w (FNV1a_32 acc) = FNV1a_32 (0x01000193 * (acc `xor32` w)) {-# INLINE fnv1a_32_Mix8 #-}  fnv1_64_Mix8 :: Word8 -> FNV1_64 -> FNV1_64-fnv1_64_Mix8 !w !(FNV1_64 acc) = FNV1_64 (0x100000001b3 * acc `xor64` w)+fnv1_64_Mix8 !w (FNV1_64 acc) = FNV1_64 (0x100000001b3 * acc `xor64` w) {-# INLINE fnv1_64_Mix8 #-}  fnv1a_64_Mix8 :: Word8 -> FNV1a_64 -> FNV1a_64-fnv1a_64_Mix8 !w !(FNV1a_64 acc) = FNV1a_64 (0x100000001b3 * (acc `xor64` w))+fnv1a_64_Mix8 !w (FNV1a_64 acc) = FNV1a_64 (0x100000001b3 * (acc `xor64` w)) {-# INLINE fnv1a_64_Mix8 #-}  instance Hasher FNV1_32 where@@ -131,7 +129,7 @@     {-# INLINE goVec #-}      goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1_32-    goAddr !(Ptr ptr) !start = return $ loop start initialState+    goAddr (Ptr ptr) !start = return $ loop start initialState       where         !len = start `offsetPlusE` A.length ba         loop !idx !acc@@ -156,7 +154,7 @@     {-# INLINE goVec #-}      goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1a_32-    goAddr !(Ptr ptr) !start = return $ loop start initialState+    goAddr (Ptr ptr) !start = return $ loop start initialState       where         !len = start `offsetPlusE` A.length ba         loop !idx !acc@@ -181,7 +179,7 @@     {-# INLINE goVec #-}      goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1_64-    goAddr !(Ptr ptr) !start = return $ loop start initialState+    goAddr (Ptr ptr) !start = return $ loop start initialState       where         !len = start `offsetPlusE` A.length ba         loop !idx !acc@@ -206,7 +204,7 @@     {-# INLINE goVec #-}      goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1a_64-    goAddr !(Ptr ptr) !start = return $ loop start initialState+    goAddr (Ptr ptr) !start = return $ loop start initialState       where         !len = start `offsetPlusE` A.length ba         loop !idx !acc

@@ -109,7 +109,7 @@         (# ist , constr ((acc .<<. 8) .|. Prelude.fromIntegral w) #)  mix8 :: Int -> Word8 -> Sip -> Sip-mix8 !c !w !(Sip ist incremental len) =+mix8 !c !w (Sip ist incremental len) =     case incremental of         SipIncremental7 acc -> Sip (process c ist ((acc .<<. 8) .|. Prelude.fromIntegral w))                                    SipIncremental0 (len+1)@@ -122,10 +122,10 @@         SipIncremental0     -> Sip ist (SipIncremental1 $ Prelude.fromIntegral w) (len+1)   where     doAcc constr acc =-        Sip ist (constr $ ((acc .<<. 8) .|. Prelude.fromIntegral w)) (len+1)+        Sip ist (constr ((acc .<<. 8) .|. Prelude.fromIntegral w)) (len+1)  mix32 :: Int -> Word32 -> Sip -> Sip-mix32 !c !w !(Sip ist incremental len) =+mix32 !c !w (Sip ist incremental len) =     case incremental of         SipIncremental0     -> Sip ist (SipIncremental4 $ Prelude.fromIntegral w) (len+4)         SipIncremental1 acc -> consume acc 32 SipIncremental5@@ -146,7 +146,7 @@     {-# INLINE consumeProcess #-}  mix64 :: Int -> Word64 -> Sip -> Sip-mix64 !c !w !(Sip ist incremental len) =+mix64 !c !w (Sip ist incremental len) =     case incremental of         SipIncremental0     -> Sip (process c ist w) SipIncremental0 (len+8)         SipIncremental1 acc -> consume acc 56 8 SipIncremental1@@ -190,7 +190,7 @@     goVec ba start = loop8 initSt initIncr start totalLen       where         loop8 !st !incr            _     0 = Sip st incr (currentLen + totalLen)-        loop8 !st !SipIncremental0 !ofs !l+        loop8 !st SipIncremental0 !ofs !l             | l < 8     = loop1 st SipIncremental0 ofs l             | otherwise =                 let v =     to64 56 (primBaIndex ba ofs)@@ -216,7 +216,7 @@     goAddr (Ptr ptr) start = return $ loop8 initSt initIncr start totalLen       where         loop8 !st !incr            _     0 = Sip st incr (currentLen + totalLen)-        loop8 !st !SipIncremental0 !ofs !l+        loop8 !st SipIncremental0 !ofs !l             | l < 8     = loop1 st SipIncremental0 ofs l             | otherwise =                 let v =     to64 56 (primAddrIndex ptr ofs)

@@ -146,7 +146,7 @@                         Just _ ->                             error ("foldTextFile: invalid UTF8 sequence: byte position: " <> show (absPos + pos))                     chunkf s acc >>= loop (absPos + Offset r)-                else error ("foldTextFile: read failed") -- FIXME+                else error "foldTextFile: read failed" -- FIXME {-# DEPRECATED foldTextFile "use conduit instead" #-}  blockSize :: Int

@@ -13,12 +13,13 @@     ) where  import Foundation.Internal.Base+import Control.Monad ((>=>))  -- | Simple State monad newtype State s m a = State { runState :: s -> m (a, s) }  instance Monad m => Functor (State s m) where-    fmap f fa = State $ \st -> runState fa st >>= \(a, s2) -> return (f a, s2)+    fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2)) instance Monad m => Applicative (State s m) where     pure a = State $ \st -> return (a,st)     fab <*> fa = State $ \s1 -> do@@ -35,7 +36,7 @@ newtype Reader r m a = Reader { runReader :: r -> m a }  instance Monad m => Functor (Reader r m) where-    fmap f fa = Reader $ \r -> runReader fa r >>= \a -> return (f a)+    fmap f fa = Reader $ runReader fa >=> (\a -> return (f a)) instance Monad m => Applicative (Reader r m) where     pure a = Reader $ \_ -> return a     fab <*> fa = Reader $ \r -> do

@@ -51,7 +51,6 @@  instance Foldable (DList a) where     foldr f b = foldr f b . toList-    foldl f b = foldl f b . toList     foldl' f b = foldl' f b . toList  instance Collection (DList a) where

@@ -30,7 +30,6 @@     , cons     , map     , elem-    , foldl     , append     , minimum     , maximum@@ -123,9 +122,6 @@  map :: (a -> b) -> SList n a -> SList n b map f (SList l) = SList (Prelude.map f l)--foldl :: (b -> a -> b) -> b -> SList n a -> b-foldl f acc (SList l) = Prelude.foldl f acc l  zip :: SList n a -> SList n b -> SList n (a,b) zip (SList l1) (SList l2) = SList (Prelude.zip l1 l2)

@@ -38,7 +38,7 @@     {-# INLINE (>>=) #-}  instance MonadTrans (ReaderT r) where-    lift f = ReaderT $ \_ -> f+    lift f = ReaderT $ const f     {-# INLINE lift #-}  instance MonadIO m => MonadIO (ReaderT r m) where

@@ -10,8 +10,10 @@     , runStateT     ) where +import Foundation.Class.Bifunctor (first) import Foundation.Internal.Base (($), (.), const) import Foundation.Monad.Base+import Control.Monad ((>=>))  class Monad m => MonadState m where     type State m@@ -27,7 +29,7 @@ newtype StateT s m a = StateT { runStateT :: s -> m (a, s) }  instance Functor m => Functor (StateT s m) where-    fmap f m = StateT $ \s1 -> (\(a, s2) -> (f a, s2)) `fmap` runStateT m s1+    fmap f m = StateT $ \s1 -> (first f) `fmap` runStateT m s1     {-# INLINE fmap #-}  instance (Applicative m, Monad m) => Applicative (StateT s m) where@@ -42,7 +44,7 @@ instance (Functor m, Monad m) => Monad (StateT s m) where     return a = StateT $ \s -> (,s) `fmap` return a     {-# INLINE return #-}-    ma >>= mab = StateT $ \s1 -> runStateT ma s1 >>= \(a, s2) -> runStateT (mab a) s2+    ma >>= mab = StateT $ runStateT ma >=> (\(a, s2) -> runStateT (mab a) s2)     {-# INLINE (>>=) #-}  instance MonadTrans (StateT s) where

@@ -8,7 +8,9 @@ -- IPv4 data type -- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}  module Foundation.Network.IPv4     ( IPv4@@ -58,7 +60,7 @@ toString = fromList . toLString  fromLString :: [Char] -> IPv4-fromLString = parseOnly ipv4Parser+fromLString = either throw id . parseOnly ipv4Parser  toLString :: IPv4 -> [Char] toLString ipv4 =@@ -91,20 +93,16 @@     w4 = w         .&. 0x000000FF  -- | Parse a IPv4 address-ipv4Parser :: (Sequential input, Element input ~ Char) => Parser input IPv4+ipv4Parser :: ( ParserSource input, Element input ~ Char+              , Sequential (Chunk input), Element input ~ Element (Chunk input)+              )+           => Parser input IPv4 ipv4Parser = do-    i1 <- takeAWord8-    element '.'-    i2 <- takeAWord8-    element '.'-    i3 <- takeAWord8-    element '.'+    i1 <- takeAWord8 <* element '.'+    i2 <- takeAWord8 <* element '.'+    i3 <- takeAWord8 <* element '.'     i4 <- takeAWord8     return $ fromTuple (i1, i2, i3, i4)   where-    takeAWord8 :: (Sequential input, Element input ~ Char)-               => Parser input Word8-    takeAWord8 =-        read <$> repeat (Between Once (toEnum 3)) (satisfy isAsciiDecimal)-    isAsciiDecimal :: Char -> Bool+    takeAWord8 = read . toList <$> takeWhile isAsciiDecimal     isAsciiDecimal = flip elem ['0'..'9']

@@ -7,9 +7,7 @@ -- -- IPv6 data type ---{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Foundation.Network.IPv6     ( IPv6@@ -37,7 +35,7 @@ import Foundation.Primitive import Foundation.Primitive.Types.OffsetSize import Foundation.Numerical-import Foundation.Collection (Sequential, Element, length, intercalate, replicate, null)+import Foundation.Collection (Element, length, intercalate, replicate, null) import Foundation.Parser import Foundation.String (String) import Foundation.Bits@@ -111,7 +109,7 @@ showHex = Base.printf "%04x"  fromLString :: [Char] -> IPv6-fromLString = parseOnly ipv6Parser+fromLString = either throw id . parseOnly ipv6Parser   -- | create an IPv6 from the given tuple@@ -160,7 +158,7 @@ -- <|> ipv6ParserCompressed -- ``` ---ipv6Parser :: (Sequential input, Element input ~ Char)+ipv6Parser :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)            => Parser input IPv6 ipv6Parser =  ipv6ParserPreferred           <|> ipv6ParserIpv4Embedded@@ -174,7 +172,7 @@ -- * `ABCD:EF01:2345:6789:ABCD:EF01:2345:6789` -- * `2001:DB8:0:0:8:800:200C:417A` ---ipv6ParserPreferred :: (Sequential input, Element input ~ Char)+ipv6ParserPreferred :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)                     => Parser input IPv6 ipv6ParserPreferred = do     i1 <- takeAWord16 <* skipColon@@ -187,6 +185,7 @@     i8 <- takeAWord16     return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8) + -- | IPv6 address with embedded IPv4 address -- -- when dealing with a mixed environment of IPv4 and IPv6 nodes is@@ -200,16 +199,14 @@ -- * `::13.1.68.3` -- * `::FFFF:129.144.52.38` ---ipv6ParserIpv4Embedded :: (Sequential input, Element input ~ Char)+ipv6ParserIpv4Embedded :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)                        => Parser input IPv6 ipv6ParserIpv4Embedded = do-    bs1 <- repeat (Between Never (toEnum 6)) $-              takeAWord16 <* skipColon+    bs1 <- repeat (Between $ 0 `And` 6 ) $ takeAWord16 <* skipColon     _ <- optional skipColon     _ <- optional skipColon     let (CountOf lenBs1) = length bs1-    bs2 <- repeat (Between Never (toEnum $ 6 - lenBs1)) $-              takeAWord16 <* skipColon+    bs2 <- repeat (Between $ 0 `And` (fromIntegral $ 6 - lenBs1)) $ takeAWord16 <* skipColon     _ <- optional skipColon     [i1,i2,i3,i4,i5,i6] <- format 6 bs1 bs2     m1 <- takeAWord8 <* skipDot@@ -232,14 +229,13 @@ -- * `::1` -- * `::` ---ipv6ParserCompressed :: (Sequential input, Element input ~ Char)+ipv6ParserCompressed :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)                      => Parser input IPv6 ipv6ParserCompressed = do-    bs1 <- repeat (Between Never (toEnum 8)) $-              takeAWord16 <* skipColon+    bs1 <- repeat (Between $ 0 `And` 8) $ takeAWord16 <* skipColon     when (null bs1) skipColon     let (CountOf bs1Len) = length bs1-    bs2 <- repeat (Between Never (toEnum $ 8 - bs1Len)) $+    bs2 <- repeat (Between $ 0 `And` fromIntegral (8 - bs1Len)) $               skipColon *> takeAWord16     [i1,i2,i3,i4,i5,i6,i7,i8] <- format 8 bs1 bs2     return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8)@@ -251,20 +247,19 @@         let len = sz `sizeSub` (length bs1 + length bs2)         return $ bs1 <> replicate len 0 <> bs2 -skipColon :: (Sequential input, Element input ~ Char)+skipColon :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)           => Parser input () skipColon = element ':'-skipDot :: (Sequential input, Element input ~ Char)+skipDot :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)         => Parser input () skipDot = element '.'-takeAWord8 :: (Sequential input, Element input ~ Char)+takeAWord8 :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)            => Parser input Word16-takeAWord8 = do-    read <$> repeat (Between Once (toEnum 3)) (satisfy isDigit)-takeAWord16 :: (Sequential input, Element input ~ Char)+takeAWord8 = read <$> repeat (Between $ 1 `And` 4) (satisfy_ isDigit)+takeAWord16 :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char)             => Parser input Word16 takeAWord16 = do-    l <- repeat (Between Once (toEnum 4)) (satisfy isHexDigit)+    l <- repeat (Between $ 1 `And` 4) (satisfy_ isHexDigit)     let lhs = readHex l      in case lhs of           [(w, [])] -> return w

@@ -13,7 +13,6 @@ -- the number of classes. -- {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Foundation.Numerical

@@ -1,4 +1,3 @@-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE CPP               #-} {-# LANGUAGE MagicHash         #-} module Foundation.Numerical.Additive

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TypeSynonymInstances #-} module Foundation.Numerical.Multiplicative     ( Multiplicative(..)

@@ -8,125 +8,205 @@ -- The current implementation is mainly, if not copy/pasted, inspired from -- `memory`'s Parser. ----- A very simple bytearray parser related to Parsec and Attoparsec+-- Foundation Parser makes use of the Foundation's @Collection@ and+-- @Sequential@ classes to allow you to define generic parsers over any+-- @Sequential@ of inpu. ----- Simple example:+-- This way you can easily implements parsers over @LString@, @String@. ----- > > parse ((,,) <$> take 2 <*> element 0x20 <*> (elements "abc" *> anyElement)) "xx abctest"--- > ParseOK "est" ("xx", 116) --+-- > flip parseOnly "my.email@address.com" $ do+-- >    EmailAddress+-- >      <$> (takeWhile ((/=) '@' <*  element '@')+-- >      <*> takeAll+--  {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-}  module Foundation.Parser-    ( Parser(..)-    , Result(..)-    , ParserError(..)-    -- * run the Parser+    ( Parser     , parse     , parseFeed     , parseOnly-    -- * Parser methods-    , hasMore-    , element-    , satisfy+    , -- * Result+      Result(..)+    , ParseError(..)++    , -- * Parser source+      ParserSource(..)++    , -- * combinator+      element     , anyElement     , elements     , string++    , satisfy+    , satisfy_     , take     , takeWhile     , takeAll+     , skip     , skipWhile     , skipAll-    -- * utils++    , (<|>)+    , many+    , some     , optional-    , many, some, (<|>)-    , Count(..), Condition(..), repeat+    , repeat, Condition(..), And(..)     ) where  import           Control.Applicative (Alternative, empty, (<|>), many, some, optional)-import           Control.Monad       (MonadPlus, mzero, mplus)+import           Control.Monad (MonadPlus, mzero, mplus)+ import           Foundation.Internal.Base import           Foundation.Primitive.Types.OffsetSize-import           Foundation.Collection hiding (take)-import           Foundation.String import           Foundation.Numerical+import           Foundation.Collection hiding (take, takeWhile)+import qualified Foundation.Collection as C+import           Foundation.String -data ParserError input-    = Expected-        { expectedInput :: !input-            -- ^ the expected input-        , receivedInput :: !input-           -- ^ but received this data-        }-    | DoesNotSatify-        -- ^ some bytes didn't satisfy predicate-    | NotEnough-        -- ^ not enough data to complete the parser-    | MonadFail String-        -- ^ only use in the event of Monad.fail function-  deriving (Show, Eq, Ord, Typeable)-instance (Show input, Typeable input) => Exception (ParserError input)+-- Error handling ------------------------------------------------------------- --- | Simple parsing result, that represent respectively:------ * failure: with the error message------ * continuation: that need for more input data------ * success: the remaining unparsed data and the parser value----data Result input a =-      ParseFail (ParserError input)-    | ParseMore (Maybe input -> Result input a)-    | ParseOK   input a+-- | common parser error definition+data ParseError input+    = NotEnough (CountOf (Element input))+        -- ^ meaning the parser was short of @CountOf@ @Element@ of `input`.+    | NotEnoughParseOnly+        -- ^ The parser needed more data, only when using @parseOnly@+    | ExpectedElement (Element input) (Element input)+        -- ^ when using @element@+    | Expected (Chunk input) (Chunk input)+        -- ^ when using @elements@ or @string@+    | Satisfy (Maybe String)+        -- ^ the @satisfy@ or @satisfy_@ function failed,+  deriving (Typeable)+instance Typeable input => Exception (ParseError input) -instance (Show ba, Show a) => Show (Result ba a) where-    show (ParseFail err) = "ParseFailure: " <> show err-    show (ParseMore _)   = "ParseMore _"-    show (ParseOK b a)   = "ParseOK " <> show a <> " " <> show b+instance Show (ParseError input) where+    show (NotEnough (CountOf sz)) = "NotEnough: missing " <> show sz <> " element(s)"+    show NotEnoughParseOnly    = "NotEnough, parse only"+    show (ExpectedElement _ _) = "Expected _ but received _"+    show (Expected _ _)        = "Expected _ but received _"+    show (Satisfy Nothing)     = "Satisfy"+    show (Satisfy (Just s))    = "Satisfy: " <> toList s --- | The continuation of the current buffer, and the error string-type Failure input r = input -> ParserError input -> Result input r+-- Results -------------------------------------------------------------------- --- | The continuation of the next buffer value, and the parsed value-type Success input a r = input -> a -> Result input r+-- | result of executing the `parser` over the given `input`+data Result input result+    = ParseFailed (ParseError input)+        -- ^ the parser failed with the given @ParserError@+    | ParseOk     (Chunk input) result+        -- ^ the parser complete successfuly with the remaining @Chunk@+    | ParseMore   (Chunk input -> Result input result)+        -- ^ the parser needs more input, pass an empty @Chunk@ or @mempty@+        -- to tell the parser you don't have anymore inputs. --- | Simple parser structure-newtype Parser input a = Parser-    { runParser :: forall r . input-                           -> Failure input r-                           -> Success input a r-                           -> Result input r }+instance Show k => Show (Result input k) where+    show (ParseFailed err) = "Parser failed: " <> show err+    show (ParseOk _ k) = "Parser succeed: " <> show k+    show (ParseMore _) = "Parser incomplete: need more"+instance Functor (Result input) where+    fmap f r = case r of+        ParseFailed err -> ParseFailed err+        ParseOk rest a  -> ParseOk rest (f a)+        ParseMore more -> ParseMore (fmap f . more) +-- Parser Source --------------------------------------------------------------++class (Sequential input, IndexedCollection input) => ParserSource input where+    type Chunk input++    nullChunk :: input -> Chunk input -> Bool++    appendChunk :: input -> Chunk input -> input++    subChunk :: input -> Offset (Element input) -> CountOf (Element input) -> Chunk input++    spanChunk :: input -> Offset (Element input) -> (Element input -> Bool) -> (Chunk input, Offset (Element input))++endOfParserSource :: ParserSource input => input -> Offset (Element input) -> Bool+endOfParserSource l off = off .==# length l+{-# INLINE endOfParserSource #-}++-- Parser ---------------------------------------------------------------------++data NoMore = More | NoMore+  deriving (Show, Eq)++type Failure input         result = input -> Offset (Element input) -> NoMore -> ParseError input -> Result input result++type Success input result' result = input -> Offset (Element input) -> NoMore -> result'          -> Result input result++-- | Foundation's @Parser@ monad.+--+-- Its implementation is based on the parser in `memory`.+newtype Parser input result = Parser+    { runParser :: forall result'+                 . input -> Offset (Element input) -> NoMore+                -> Failure input        result'+                -> Success input result result'+                -> Result input result'+    }+ instance Functor (Parser input) where-    fmap f p = Parser $ \buf err ok ->-       runParser p buf err (\b a -> ok b (f a))-instance Applicative (Parser input) where-    pure      = return-    (<*>) d e = d >>= \b -> e >>= \a -> return (b a)-instance Monad (Parser input) where-    fail errorMsg = Parser $ \buf err _ -> err buf (MonadFail $ fromList errorMsg)-    return v      = Parser $ \buf _ ok -> ok buf v-    m >>= k       = Parser $ \buf err ok ->-        runParser m buf err (\buf' a -> runParser (k a) buf' err ok)-instance MonadPlus (Parser input) where-    mzero = fail "MonadPlus.mzero"-    mplus f g = Parser $ \buf err ok ->-        -- rewrite the err callback of @f to call @g-        runParser f buf (\_ _ -> runParser g buf err ok) ok-instance Alternative (Parser input) where-    empty = fail "Alternative.empty"+    fmap f fa = Parser $ \buf off nm err ok ->+        runParser fa buf off nm err $ \buf' off' nm' a -> ok buf' off' nm' (f a)+    {-# INLINE fmap #-}++instance ParserSource input => Applicative (Parser input) where+    pure a = Parser $ \buf off nm _ ok -> ok buf off nm a+    {-# INLINE pure #-}+    fab <*> fa = Parser $ \buf0 off0 nm0 err ok ->+        runParser  fab buf0 off0 nm0 err $ \buf1 off1 nm1 ab ->+        runParser_ fa  buf1 off1 nm1 err $ \buf2 off2 nm2 -> ok buf2 off2 nm2 . ab+    {-# INLINE (<*>) #-}++instance ParserSource input => Monad (Parser input) where+    return = pure+    {-# INLINE return #-}+    m >>= k       = Parser $ \buf off nm err ok ->+        runParser  m     buf  off  nm  err $ \buf' off' nm' a ->+        runParser_ (k a) buf' off' nm' err ok+    {-# INLINE (>>=) #-}++instance ParserSource input => MonadPlus (Parser input) where+    mzero = error "Foundation.Parser.Internal.MonadPlus.mzero"+    mplus f g = Parser $ \buf off nm err ok ->+        runParser f buf off nm (\buf' _ nm' _ -> runParser g buf' off nm' err ok) ok+    {-# INLINE mplus #-}+instance ParserSource input => Alternative (Parser input) where+    empty = error "Foundation.Parser.Internal.Alternative.empty"     (<|>) = mplus+    {-# INLINE (<|>) #-} +runParser_ :: ParserSource input+           => Parser input result+           -> input+           -> Offset (Element input)+           -> NoMore+           -> Failure input        result'+           -> Success input result result'+           -> Result input         result'+runParser_ parser buf off NoMore err ok = runParser parser buf off NoMore err ok+runParser_ parser buf off nm     err ok+    | endOfParserSource buf off = ParseMore $ \chunk ->+        if nullChunk buf chunk+            then runParser parser buf off NoMore err ok+            else runParser parser (appendChunk buf chunk) off nm err ok+    | otherwise = runParser parser buf                    off nm err ok+{-# INLINE runParser_ #-}+ -- | Run a parser on an @initial input. -- -- If the Parser need more data than available, the @feeder function -- is automatically called and fed to the More continuation.-parseFeed :: (Sequential input, Monad m)-          => m (Maybe input)+parseFeed :: (ParserSource input, Monad m)+          => m (Chunk input)           -> Parser input a           -> input           -> m (Result input a)@@ -135,250 +215,268 @@         loop r             = return r  -- | Run a Parser on a ByteString and return a 'Result'-parse :: Sequential input+parse :: ParserSource input       => Parser input a -> input -> Result input a-parse p s = runParser p s (\_ msg -> ParseFail msg) ParseOK+parse p s = runParser p s 0 More failure success +failure :: input -> Offset (Element input) -> NoMore -> ParseError input -> Result input r+failure _ _ _ = ParseFailed+{-# INLINE failure #-}++success :: ParserSource input => input -> Offset (Element input) -> NoMore -> r -> Result input r+success buf off _ = ParseOk rest+  where+    !rest = subChunk buf off (length buf - offsetAsSize off)+{-# INLINE success #-}+ -- | parse only the given input -- -- The left-over `Element input` will be ignored, if the parser call for more -- data it will be continuously fed with `Nothing` (up to 256 iterations). ---parseOnly :: (Typeable input, Show input, Sequential input, Element input ~ Char)+parseOnly :: (ParserSource input, Monoid (Chunk input))           => Parser input a           -> input-          -> a-parseOnly p i = continuously maximumIterations (parse p i)-  where-    maximumIterations :: Int-    maximumIterations = 256-    continuously _ (ParseOK _ a) = a-    continuously _ (ParseFail err) = throw err-    continuously n (ParseMore f)-        | n == 0 = error "Foundation.Parser.parseOnly: not enough (please report error)"-        | otherwise = continuously (n - 1) (f Nothing)+          -> Either (ParseError input) a+parseOnly p i = case runParser p i 0 NoMore failure success of+    ParseFailed err  -> Left err+    ParseOk     _ r  -> Right r+    ParseMore   _    -> Left NotEnoughParseOnly --- When needing more data, getMore append the next data--- to the current buffer. if no further data, then--- the err callback is called.-getMore :: Sequential input => Parser input ()-getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk ->-    case nextChunk of-        Nothing -> err buf NotEnough-        Just nc-            | null nc   -> runParser getMore buf err ok-            | otherwise -> ok (mappend buf nc) ()+-- ------------------------------------------------------------------------- --+--                              String Parser                                --+-- ------------------------------------------------------------------------- -- ------ Only used by takeAll, which accumulate all the remaining data--- until ParseMore is fed a Nothing value.------ getAll cannot fail.-getAll :: Sequential input => Parser input ()-getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->-    case nextChunk of-        Nothing -> ok buf ()-        Just nc -> runParser getAll (mappend buf nc) err ok+instance ParserSource String where+    type Chunk String = String+    nullChunk _ = null+    {-# INLINE nullChunk #-}+    appendChunk = mappend+    {-# INLINE appendChunk #-}+    subChunk c off sz = C.take sz $ C.drop (offsetAsSize off) c+    {-# INLINE subChunk #-}+    spanChunk buf off predicate =+        let c      = C.drop (offsetAsSize off) buf+            (t, _) = C.span predicate c+          in (t, off `offsetPlusE` length t)+    {-# INLINE spanChunk #-} --- Only used by skipAll, which flush all the remaining data--- until ParseMore is fed a Nothing value.------ flushAll cannot fail.-flushAll :: Sequential input => Parser input ()-flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->-    case nextChunk of-        Nothing -> ok buf ()-        Just _  -> runParser flushAll mempty err ok+instance ParserSource [a] where+    type Chunk [a] = [a]+    nullChunk _ = null+    {-# INLINE nullChunk #-}+    appendChunk = mappend+    {-# INLINE appendChunk #-}+    subChunk c off sz = C.take sz $ C.drop (offsetAsSize off) c+    {-# INLINE subChunk #-}+    spanChunk buf off predicate =+        let c      = C.drop (offsetAsSize off) buf+            (t, _) = C.span predicate c+          in (t, off `offsetPlusE` length t)+    {-# INLINE spanChunk #-} -hasMore :: Sequential input => Parser input Bool-hasMore = Parser $ \buf err ok ->-    if null buf-        then ParseMore $ \nextChunk ->-            case nextChunk of-                Nothing -> ok buf False-                Just nc -> runParser hasMore nc err ok-        else ok buf True+-- ------------------------------------------------------------------------- --+--                          Helpers                                          --+-- ------------------------------------------------------------------------- --  -- | Get the next `Element input` from the parser-anyElement :: Sequential input => Parser input (Element input)-anyElement = Parser $ \buf err ok ->-    case uncons buf of-        Nothing      -> runParser (getMore >> anyElement) buf err ok-        Just (c1,b2) -> ok b2 c1+anyElement :: ParserSource input => Parser input (Element input)+anyElement = Parser $ \buf off nm err ok ->+    case buf ! off of+        Nothing -> err buf off        nm $ NotEnough 1+        Just x  -> ok  buf (succ off) nm x+{-# INLINE anyElement #-} --- | Parse a specific `Element input` at current position------ if the `Element input` is different than the expected one,--- this parser will raise a failure.-element :: (Sequential input, Eq (Element input))-        => Element input -> Parser input ()-element w = Parser $ \buf err ok ->-    case uncons buf of-        Nothing      -> runParser (getMore >> element w) buf err ok-        Just (c1,b2) | c1 == w   -> ok b2 ()-                     | otherwise -> err buf (Expected (singleton w) (singleton c1))+element :: ( ParserSource input+           , Eq (Element input)+           , Element input ~ Element (Chunk input)+           )+        => Element input+        -> Parser input ()+element expectedElement = Parser $ \buf off nm err ok ->+    case buf ! off of+        Nothing -> err buf off nm $ NotEnough 1+        Just x | expectedElement == x -> ok  buf (succ off) nm ()+               | otherwise            -> err buf off nm $ ExpectedElement expectedElement x+{-# INLINE element #-} --- | Parse a sequence of elements from current position------ if the following `Element input` don't match the expected--- `input` completely, the parser will raise a failure-elements :: (Show input, Eq input, Sequential input) => input -> Parser input ()+elements :: ( ParserSource input, Sequential (Chunk input)+            , Element (Chunk input) ~ Element input+            , Eq (Chunk input)+            )+         => Chunk input -> Parser input () elements = consumeEq   where-    -- partially consume as much as possible or raise an error.-    consumeEq expected = Parser $ \actual err ok ->-        let eLen = length expected in-         if length actual >= eLen-             then    -- enough data for doing a full match-                let (aMatch,aRem) = splitAt eLen actual-                 in if aMatch == expected-                     then ok aRem ()-                     else err actual (Expected expected aMatch)-             else    -- not enough data, match as much as we have, and then recurse.-                let (eMatch, eRem) = splitAt (length actual) expected-                 in if actual == eMatch-                     then runParser (getMore >> consumeEq eRem) mempty err ok-                     else err actual (Expected expected eMatch)--string :: String -> Parser String ()-string !expected = Parser $ \actual err ok ->-    let !expBytes = toBytes UTF8 expected-        !expLen   = length expBytes-        !actBytes = toBytes UTF8 actual-        !actLen   = length actBytes-     in if expLen <= actLen-          then-              let (!aMatch, !aRem) = splitAt expLen actBytes-               in if aMatch == expBytes-                   then ok (fromBytesUnsafe aRem) ()-                   else err actual (Expected expected (fromBytesUnsafe aMatch))-          else-              let (!eMatch, !eRem) = splitAt actLen expBytes-               in if actBytes == eMatch-                   then runParser (getMore >> string (fromBytesUnsafe eRem)) mempty err ok-                   else err actual (Expected expected (fromBytesUnsafe eMatch))+    consumeEq :: ( ParserSource input+                 , Sequential (Chunk input)+                 , Element (Chunk input) ~ Element input+                 , Eq (Chunk input)+                 )+              => Chunk input -> Parser input ()+    consumeEq expected = Parser $ \buf off nm err ok ->+      if endOfParserSource buf off+        then+          err buf off nm $ NotEnough lenE+        else+          let !lenI = sizeAsOffset (length buf) - off+           in if lenI >= lenE+             then+              let a = subChunk buf off lenE+               in if a == expected+                    then ok buf (off + sizeAsOffset lenE) nm ()+                    else err buf off nm $ Expected expected a+             else+              let a = subChunk buf off lenI+                  (e', r) = splitAt lenI expected+               in if a == e'+                    then runParser_ (consumeEq r) buf (off + sizeAsOffset lenI) nm err ok+                    else err buf off nm $ Expected e' a+      where+        !lenE = length expected+    {-# NOINLINE consumeEq #-}+{-# INLINE elements #-} --- | Take @n elements from the current position in the stream-take :: Sequential input => CountOf (Element input) -> Parser input input-take n = Parser $ \buf err ok ->-    if length buf >= n-        then let (b1,b2) = splitAt n buf in ok b2 b1-        else runParser (getMore >> take n) buf err ok+-- | take one element if satisfy the given predicate+satisfy :: ParserSource input => Maybe String -> (Element input -> Bool) -> Parser input (Element input)+satisfy desc predicate = Parser $ \buf off nm err ok ->+    case buf ! off of+        Nothing -> err buf off nm $ NotEnough 1+        Just x | predicate x -> ok  buf (succ off) nm x+               | otherwise   -> err buf off nm $ Satisfy desc+{-# INLINE satisfy #-}  -- | take one element if satisfy the given predicate-satisfy :: Sequential input => (Element input -> Bool) -> Parser input (Element input)-satisfy predicate = Parser $ \buf err ok ->-    case uncons buf of-        Nothing      -> runParser (getMore >> satisfy predicate) buf err ok-        Just (c1,b2) | predicate c1 -> ok b2 c1-                     | otherwise -> err buf DoesNotSatify+satisfy_ :: ParserSource input => (Element input -> Bool) -> Parser input (Element input)+satisfy_ = satisfy Nothing+{-# INLINE satisfy_ #-} --- | Take elements while the @predicate hold from the current position in the--- stream-takeWhile :: Sequential input => (Element input -> Bool) -> Parser input input-takeWhile predicate = Parser $ \buf err ok ->-    let (b1, b2) = span predicate buf-     in if null b2-            then runParser (getMore >> takeWhile predicate) buf err ok-            else ok b2 b1+take :: ( ParserSource input+        , Sequential (Chunk input)+        , Element input ~ Element (Chunk input)+        )+     => CountOf (Element (Chunk input))+     -> Parser input (Chunk input)+take n = Parser $ \buf off nm err ok ->+    let lenI = sizeAsOffset (length buf) - off+     in if endOfParserSource buf off && n > 0+       then err buf off nm $ NotEnough n+       else if n <= lenI+         then let t = subChunk buf off n+               in ok buf (off + sizeAsOffset n) nm t+         else let h = subChunk buf off lenI+               in runParser_ (take $ n - lenI) buf (sizeAsOffset lenI) nm err $+                    \buf' off' nm' t -> ok buf' off' nm' (h <> t) +takeWhile :: ( ParserSource input, Sequential (Chunk input)+             )+          => (Element input -> Bool)+          -> Parser input (Chunk input)+takeWhile predicate = Parser $ \buf off nm err ok ->+    if endOfParserSource buf off+      then ok buf off nm mempty+      else let (b1, off') = spanChunk buf off predicate+            in if endOfParserSource buf off'+                  then runParser_ (takeWhile predicate) buf off' nm err+                          $ \buf' off'' nm' b1T -> ok buf' off'' nm' (b1 <> b1T)+                  else ok buf off' nm b1+ -- | Take the remaining elements from the current position in the stream-takeAll :: Sequential input => Parser input input-takeAll = Parser $ \buf err ok ->-    runParser (getAll >> returnBuffer) buf err ok+takeAll :: (ParserSource input, Sequential (Chunk input)) => Parser input (Chunk input)+takeAll = getAll >> returnBuffer   where-    returnBuffer = Parser $ \buf _ ok -> ok mempty buf---- | Skip @n elements from the current position in the stream-skip :: Sequential input => CountOf (Element input) -> Parser input ()-skip n = Parser $ \buf err ok ->-    if length buf >= n-        then ok (drop n buf) ()-        else runParser (getMore >> skip (n `sizeSub` length buf)) mempty err ok---- | Skip `Element input` while the @predicate hold from the current position--- in the stream-skipWhile :: Sequential input => (Element input -> Bool) -> Parser input ()-skipWhile p = Parser $ \buf err ok ->-    let (_, b2) = span p buf-     in if null b2-            then runParser (getMore >> skipWhile p) mempty err ok-            else ok b2 ()+    returnBuffer :: ParserSource input => Parser input (Chunk input)+    returnBuffer = Parser $ \buf off nm _ ok ->+        let !lenI = length buf+            !off' = sizeAsOffset lenI+            !sz   = off' - off+         in ok buf off' nm (subChunk buf off sz)+    {-# INLINE returnBuffer #-} --- | Skip all the remaining `Element input` from the current position in the--- stream-skipAll :: Sequential input => Parser input ()-skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok+    getAll :: (ParserSource input, Sequential (Chunk input)) => Parser input ()+    getAll = Parser $ \buf off nm err ok ->+      case nm of+        NoMore -> ok buf off nm ()+        More   -> ParseMore $ \nextChunk ->+          if nullChunk buf nextChunk+            then ok buf off NoMore ()+            else runParser getAll (appendChunk buf nextChunk) off nm err ok+    {-# NOINLINE getAll #-}+{-# INLINE takeAll #-} -data Count = Never | Once | Twice | Other Int-  deriving (Show)-instance Enum Count where-    toEnum 0 = Never-    toEnum 1 = Once-    toEnum 2 = Twice-    toEnum n-        | n > 2 = Other n-        | otherwise = Never-    fromEnum Never = 0-    fromEnum Once = 1-    fromEnum Twice = 2-    fromEnum (Other n) = n-    succ Never = Once-    succ Once = Twice-    succ Twice = Other 3-    succ (Other n)-        | n == 0 = Once-        | n == 1 = Twice-        | otherwise = Other (succ n)-    pred Never = Never-    pred Once = Never-    pred Twice = Once-    pred (Other n)-        | n == 2 = Once-        | n == 3 = Twice-        | otherwise = Other (pred n)+skip :: ParserSource input => CountOf (Element input) -> Parser input ()+skip n = Parser $ \buf off nm err ok ->+    let lenI = sizeAsOffset (length buf) - off+     in if endOfParserSource buf off && n > 0+       then err buf off nm $ NotEnough n+       else if n <= lenI+         then ok buf (off + sizeAsOffset n) nm ()+         else runParser_ (skip $ n - lenI) buf (sizeAsOffset lenI) nm err ok -data Condition = Exactly Count-               | Between Count Count-  deriving (Show)+skipWhile :: ( ParserSource input, Sequential (Chunk input)+             )+          => (Element input -> Bool)+          -> Parser input ()+skipWhile predicate = Parser $ \buf off nm err ok ->+    if endOfParserSource buf off+      then ok buf off nm ()+      else let (_, off') = spanChunk buf off predicate+            in if endOfParserSource buf off'+                  then runParser_ (skipWhile predicate) buf off' nm err ok+                  else ok buf off' nm () -shouldStop :: Condition -> Bool-shouldStop (Exactly   Never) = True-shouldStop (Between _ Never) = True-shouldStop _                 = False+-- | consume every chunk of the stream+--+skipAll :: (ParserSource input, Collection (Chunk input)) => Parser input ()+skipAll = flushAll+  where+    flushAll :: (ParserSource input, Collection (Chunk input)) => Parser input ()+    flushAll = Parser $ \buf off nm err ok ->+        let !off' = sizeAsOffset $ length buf in+        case nm of+            NoMore -> ok buf off' NoMore ()+            More   -> ParseMore $ \nextChunk ->+              if null nextChunk+                then ok buf off' NoMore ()+                else runParser flushAll buf off nm err ok+    {-# NOINLINE flushAll #-}+{-# INLINE skipAll #-} -canStop :: Condition -> Bool-canStop (Exactly Never)   = True-canStop (Between Never _) = True-canStop _                 = False+string :: String -> Parser String ()+string = elements+{-# INLINE string #-} -decrement :: Condition -> Condition-decrement (Exactly n)   = Exactly (pred n)-decrement (Between a b) = Between (pred a) (pred b)+data Condition = Between !And | Exactly !Word+  deriving (Show, Eq, Typeable)+data And = And !Word !Word+  deriving (Eq, Typeable)+instance Show And where+    show (And a b) = show a <> " and " <> show b --- | repeat the given Parser a given amount of time+-- | repeat the given parser a given amount of time ----- If you know you want it to exactly perform a given amount of time:+-- Unlike @some@ or @many@, this operation will bring more precision on how+-- many times you wish a parser to be sequenced. ----- ```--- repeat (Exactly Twice) (element 'a')--- ```+-- ## Repeat @Exactly@ a number of time ----- If you know your parser must performs from 0 to 8 times:+-- > repeat (Exactly 6) (takeWhile ((/=) ',') <* element ',') ----- ```--- repeat (Between Never (Other 8))--- ```+-- ## Repeat @Between@ lower `@And@` upper times ----- *This interface is still WIP* but went handy when writting the IPv4/IPv6--- parsers.+-- > repeat (Between $ 1 `And` 10) (takeWhile ((/=) ',') <* element ',') ---repeat :: Sequential input => Condition -> Parser input a -> Parser input [a]-repeat c p-    | shouldStop c = return []-    | otherwise = do-        ma <- optional p-        case ma of-            Nothing | canStop c -> return []-                    | otherwise -> fail $ "Not enough..." <> show c-            Just a -> (:) a <$> repeat (decrement c) p+repeat :: ParserSource input+       => Condition -> Parser input a -> Parser input [a]+repeat (Exactly n) = repeatE n+repeat (Between a) = repeatA a++repeatE :: (ParserSource input)+        => Word -> Parser input a -> Parser input [a]+repeatE 0 _ = return []+repeatE n p = (:) <$> p <*> repeatE (n-1) p++repeatA :: (ParserSource input)+        => And -> Parser input a -> Parser input [a]+repeatA (And 0 0) _ = return []+repeatA (And 0 n) p = ((:) <$> p <*> repeatA (And 0     (n-1)) p) <|> return []+repeatA (And l u) p =  (:) <$> p <*> repeatA (And (l-1) (u-1)) p

@@ -8,7 +8,6 @@ -- Different collections (list, vector, string, ..) unified under 1 API. -- an API to rules them all, and in the darkness bind them. ---{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Primitive     ( PrimType(..)

@@ -32,9 +32,10 @@     , replicate     , index     , map-    , foldl     , foldl'     , foldr+    , foldl1'+    , foldr1     , cons     , snoc     , uncons@@ -64,6 +65,7 @@ import           Foundation.Internal.Base import           Foundation.Internal.Proxy import           Foundation.Internal.Primitive+import           Foundation.Collection.NonEmpty import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import           Foundation.Primitive.Exception@@ -140,14 +142,6 @@ map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))   where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a) -foldl :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a-foldl f initialAcc vec = loop 0 initialAcc-  where-    !len = length vec-    loop i acc-        | i .==# len = acc-        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))- foldr :: PrimType ty => (ty -> a -> a) -> a -> Block ty -> a foldr f initialAcc vec = loop 0   where@@ -163,6 +157,14 @@     loop i !acc         | i .==# len = acc         | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))++foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty+foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr+               in foldl' f (unsafeIndex initialAcc 0) rest++foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty+foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr+               in foldr f (unsafeIndex initialAcc 0) rest  cons :: PrimType ty => ty -> Block ty -> Block ty cons e vec

@@ -21,6 +21,8 @@     -- * Other methods     , new     , newPinned+    , touch+    , mutableTouch     ) where  import           GHC.Prim@@ -324,3 +326,10 @@ unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim () unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v {-# INLINE unsafeWrite #-}++touch :: PrimMonad prim => Block ty -> prim ()+touch (Block ba) = unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }++mutableTouch :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim ()+mutableTouch (MutableBlock mba) = unsafePrimFromIO $ primitive $ \s -> case touch# mba s of { s2 -> (# s2, () #) }+

@@ -529,7 +529,7 @@ {-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-}  primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b-primOffsetRecastBytes !(Offset o) = Offset (szA `Prelude.quot` o)+primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o)   where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b) {-# INLINE [1] primOffsetRecastBytes #-} 

@@ -18,6 +18,7 @@     , offsetMinusE     , offsetRecast     , offsetCast+    , offsetSub     , sizeCast     , sizeLastOffset     , sizeAsOffset@@ -108,6 +109,13 @@  offsetMinusE :: Offset ty -> CountOf ty -> Offset ty offsetMinusE (Offset ofs) (CountOf sz) = Offset (ofs - sz)++-- | subtract 2 CountOf values of the same type.+--+-- m need to be greater than n, otherwise negative count error ensue+-- use the safer (-) version if unsure.+offsetSub :: Offset a -> Offset a -> Offset a+offsetSub (Offset m) (Offset n) = Offset (m - n)  offsetRecast :: Size8 -> Size8 -> Offset ty -> Offset ty2 offsetRecast szTy (CountOf szTy2) ofs =

@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Foundation.Primitive.UTF8.Addr+    ( Immutable+    , Mutable+    -- * functions+    , nextAscii+    , nextAsciiDigit+    , expectAscii+    , next+    , prev+    , prevSkip+    , write+    -- temporary+    , primIndex+    , primRead+    , primWrite+    ) where++import           GHC.Int+import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Foundation.Internal.Base+import           Foundation.Internal.Primitive+import           Foundation.Numerical+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Types+import           Foundation.Primitive.UTF8.Helper+import           Foundation.Primitive.UTF8.Table+import           Foundation.Bits++type Immutable = Addr#+type Mutable (prim :: * -> *) = Addr#++primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim ()+primWrite = primAddrWrite++primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8+primRead = primAddrRead++primIndex :: Immutable -> Offset Word8 -> Word8+primIndex = primAddrIndex+++nextAscii :: Immutable -> Offset Word8 -> (# Word8, Bool #)+nextAscii ba n = (# w, not (testBit w 7) #)+  where+    !w = primIndex ba n+{-# INLINE nextAscii #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigit :: Immutable -> Offset Word8 -> (# Word8, Bool #)+nextAsciiDigit ba n = (# d, d < 0xa #)+  where !d = primIndex ba n - 0x30+{-# INLINE nextAsciiDigit #-}++expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool+expectAscii ba n v = primIndex ba n == v+{-# INLINE expectAscii #-}++next :: Immutable -> Offset8 -> (# Char, Offset8 #)+next ba n =+    case getNbBytes h of+        0 -> (# toChar1 h, n + Offset 1 #)+        1 -> (# toChar2 h (primIndex ba (n + Offset 1)) , n + Offset 2 #)+        2 -> (# toChar3 h (primIndex ba (n + Offset 1))+                          (primIndex ba (n + Offset 2)) , n + Offset 3 #)+        3 -> (# toChar4 h (primIndex ba (n + Offset 1))+                          (primIndex ba (n + Offset 2))+                          (primIndex ba (n + Offset 3)) , n + Offset 4 #)+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)+  where+    !h = primIndex ba n+{-# INLINE next #-}++-- Given a non null offset, give the previous character and the offset of this character+-- will fail bad if apply at the beginning of string or an empty string.+prev :: Immutable -> Offset Word8 -> (# Char, Offset8 #)+prev ba offset =+    case primIndex ba prevOfs1 of+        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)+                 | otherwise          -> (# toChar# v1, prevOfs1 #)+  where+    sz1 = CountOf 1+    !prevOfs1 = offset `offsetMinusE` sz1+    prevOfs2 = prevOfs1 `offsetMinusE` sz1+    prevOfs3 = prevOfs2 `offsetMinusE` sz1+    prevOfs4 = prevOfs3 `offsetMinusE` sz1+    atLeast2 !v  =+        case primIndex ba prevOfs2 of+            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)+                     | otherwise          -> (# toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v), prevOfs2 #)+    atLeast3 !v =+        case primIndex ba prevOfs3 of+            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)+                     | otherwise          -> (# toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v), prevOfs3 #)+    atLeast4 !v =+        case primIndex ba prevOfs4 of+            (W8# v4) -> (# toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v), prevOfs4 #)++prevSkip :: Immutable -> Offset Word8 -> Offset Word8+prevSkip ba offset = loop (offset `offsetMinusE` sz1)+  where+    sz1 = CountOf 1+    loop o+        | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1)+        | otherwise                       = o++write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8+write mba !i !c+    | bool# (ltWord# x 0x80##   ) = encode1+    | bool# (ltWord# x 0x800##  ) = encode2+    | bool# (ltWord# x 0x10000##) = encode3+    | otherwise                   = encode4+  where+    !(I# xi) = fromEnum c+    !x       = int2Word# xi++    encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1)+    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        primWrite mba i     (W8# x1)+        primWrite mba (i+1) (W8# x2)+        pure (i + Offset 2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        pure (i + Offset 3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        primWrite mba (i+Offset 3) (W8# x4)+        pure (i + Offset 4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE write #-}

@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Foundation.Primitive.UTF8.BA+    ( Immutable+    , Mutable+    -- * functions+    , nextAscii+    , nextAsciiDigit+    , expectAscii+    , next+    , prev+    , prevSkip+    , write+    -- temporary+    , primIndex+    , primRead+    , primWrite+    ) where++import           GHC.Int+import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Foundation.Internal.Base+import           Foundation.Internal.Primitive+import           Foundation.Numerical+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Types+import           Foundation.Primitive.UTF8.Helper+import           Foundation.Primitive.UTF8.Table+import           Foundation.Bits++type Immutable = ByteArray#+type Mutable prim = MutableByteArray# (PrimState prim)++primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim ()+primWrite = primMbaWrite++primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8+primRead = primMbaRead++primIndex :: Immutable -> Offset Word8 -> Word8+primIndex = primBaIndex+++nextAscii :: Immutable -> Offset Word8 -> (# Word8, Bool #)+nextAscii ba n = (# w, not (testBit w 7) #)+  where+    !w = primIndex ba n+{-# INLINE nextAscii #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigit :: Immutable -> Offset Word8 -> (# Word8, Bool #)+nextAsciiDigit ba n = (# d, d < 0xa #)+  where !d = primIndex ba n - 0x30+{-# INLINE nextAsciiDigit #-}++expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool+expectAscii ba n v = primIndex ba n == v+{-# INLINE expectAscii #-}++next :: Immutable -> Offset8 -> (# Char, Offset8 #)+next ba n =+    case getNbBytes h of+        0 -> (# toChar1 h, n + Offset 1 #)+        1 -> (# toChar2 h (primIndex ba (n + Offset 1)) , n + Offset 2 #)+        2 -> (# toChar3 h (primIndex ba (n + Offset 1))+                          (primIndex ba (n + Offset 2)) , n + Offset 3 #)+        3 -> (# toChar4 h (primIndex ba (n + Offset 1))+                          (primIndex ba (n + Offset 2))+                          (primIndex ba (n + Offset 3)) , n + Offset 4 #)+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h)+  where+    !h = primIndex ba n+{-# INLINE next #-}++-- Given a non null offset, give the previous character and the offset of this character+-- will fail bad if apply at the beginning of string or an empty string.+prev :: Immutable -> Offset Word8 -> (# Char, Offset8 #)+prev ba offset =+    case primIndex ba prevOfs1 of+        (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)+                 | otherwise          -> (# toChar# v1, prevOfs1 #)+  where+    sz1 = CountOf 1+    !prevOfs1 = offset `offsetMinusE` sz1+    prevOfs2 = prevOfs1 `offsetMinusE` sz1+    prevOfs3 = prevOfs2 `offsetMinusE` sz1+    prevOfs4 = prevOfs3 `offsetMinusE` sz1+    atLeast2 !v  =+        case primIndex ba prevOfs2 of+            (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)+                     | otherwise          -> (# toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v), prevOfs2 #)+    atLeast3 !v =+        case primIndex ba prevOfs3 of+            (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)+                     | otherwise          -> (# toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v), prevOfs3 #)+    atLeast4 !v =+        case primIndex ba prevOfs4 of+            (W8# v4) -> (# toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v), prevOfs4 #)++prevSkip :: Immutable -> Offset Word8 -> Offset Word8+prevSkip ba offset = loop (offset `offsetMinusE` sz1)+  where+    sz1 = CountOf 1+    loop o+        | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1)+        | otherwise                       = o++write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8+write mba !i !c+    | bool# (ltWord# x 0x80##   ) = encode1+    | bool# (ltWord# x 0x800##  ) = encode2+    | bool# (ltWord# x 0x10000##) = encode3+    | otherwise                   = encode4+  where+    !(I# xi) = fromEnum c+    !x       = int2Word# xi++    encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1)+    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        primWrite mba i     (W8# x1)+        primWrite mba (i+1) (W8# x2)+        pure (i + Offset 2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        pure (i + Offset 3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        primWrite mba i            (W8# x1)+        primWrite mba (i+Offset 1) (W8# x2)+        primWrite mba (i+Offset 2) (W8# x3)+        primWrite mba (i+Offset 3) (W8# x4)+        pure (i + Offset 4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE write #-}

@@ -17,19 +17,20 @@     where  import           GHC.ST (ST, runST)-import           GHC.Int import           GHC.Types import           GHC.Word import           GHC.Prim import           Foundation.Internal.Base-import           Foundation.Internal.Primitive import           Foundation.Numerical import           Foundation.Bits+import           Foundation.Class.Bifunctor import           Foundation.Primitive.NormalForm import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad-import           Foundation.Primitive.UTF8.Table+import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.UTF8.Helper+import qualified Foundation.Primitive.UTF8.BA       as PrimBA+import qualified Foundation.Primitive.UTF8.Addr     as PrimAddr import           Foundation.Array.Unboxed           (UArray) import qualified Foundation.Array.Unboxed           as Vec import qualified Foundation.Array.Unboxed           as C@@ -119,40 +120,28 @@ {-# INLINE [0] sFromList #-}  next :: String -> Offset8 -> (# Char, Offset8 #)-next (String ba) n =-    case getNbBytes# h of-        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))) , n + 3 #)-        3# -> (# toChar (decode4 (Vec.unsafeIndex ba (n + 1))-                                 (Vec.unsafeIndex ba (n + 2))-                                 (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))+next (String array) n =+    case array of+        Vec.UVecBA start _ _ ba   -> let (# c, o #) = PrimBA.next ba (start + n)+                                      in (# c, o `offsetSub` start #)+        Vec.UVecAddr start _ fptr -> unt2 $ withUnsafeFinalPtr fptr $ \(Ptr ptr) -> pureST $ t2 start (PrimAddr.next ptr (start + n))   where-    !(W8# h) = Vec.unsafeIndex ba n--    toChar :: Word# -> Char-    toChar w = C# (chr# (word2Int# w))--    decode2 :: Word8 -> Word#-    decode2 (W8# c1) =-        or# (uncheckedShiftL# (and# h 0x1f##) 6#)-            (and# c1 0x3f##)--    decode3 :: Word8 -> Word8 -> Word#-    decode3 (W8# c1) (W8# c2) =-        or# (uncheckedShiftL# (and# h 0xf##) 12#)-            (or# (uncheckedShiftL# (and# c1 0x3f##) 6#)-                 (and# c2 0x3f##))+    pureST :: a -> ST s a+    pureST = pure+    unt2 (a,b) = (# a, b #)+    t2 x (# a, b #) = (a, b `offsetSub` x) -    decode4 :: Word8 -> Word8 -> Word8 -> Word#-    decode4 (W8# c1) (W8# c2) (W8# c3) =-        or# (uncheckedShiftL# (and# h 0x7##) 18#)-            (or# (uncheckedShiftL# (and# c1 0x3f##) 12#)-                (or# (uncheckedShiftL# (and# c2 0x3f##) 6#)-                    (and# c3 0x3f##))-            )+prev :: String -> Offset8 -> (# Char, Offset8 #)+prev (String array) n =+    case array of+        Vec.UVecBA start _ _ ba   -> let (# c, o #) = PrimBA.prev ba (start + n)+                                      in (# c, o `offsetSub` start #)+        Vec.UVecAddr start _ fptr -> unt2 $ withUnsafeFinalPtr fptr $ \(Ptr ptr) -> pureST $ t2 start (PrimAddr.prev ptr (start + n))+  where+    pureST :: a -> ST s a+    pureST = pure+    unt2 (a,b) = (# a, b #)+    t2 x (# a, b #) = (a, b `offsetSub` x)  -- A variant of 'next' when you want the next character -- to be ASCII only. if Bool is False, then it's not ascii,@@ -167,47 +156,10 @@ {-# INLINE expectAscii #-}  write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8-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-    else                                     encode4-  where-    !(I# xi) = fromEnum c-    !x       = int2Word# xi--    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 (i + 2)--    encode3 = do-        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##-            x2  = toContinuation (uncheckedShiftRL# x 6#)-            x3  = toContinuation x-        Vec.unsafeWrite mba i     (W8# x1)-        Vec.unsafeWrite mba (i+1) (W8# x2)-        Vec.unsafeWrite mba (i+2) (W8# x3)-        return (i + 3)--    encode4 = do-        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##-            x2  = toContinuation (uncheckedShiftRL# x 12#)-            x3  = toContinuation (uncheckedShiftRL# x 6#)-            x4  = toContinuation x-        Vec.unsafeWrite mba i     (W8# x1)-        Vec.unsafeWrite mba (i+1) (W8# x2)-        Vec.unsafeWrite mba (i+2) (W8# x3)-        Vec.unsafeWrite mba (i+3) (W8# x4)-        return (i + 4)--    toContinuation :: Word# -> Word#-    toContinuation w = or# (and# w 0x3f##) 0x80##-{-# INLINE write #-}+write (MutableString marray) ofs c =+    case marray of+        MVec.MUVecMA start _ _ mba  -> PrimBA.write mba (start + ofs) c+        MVec.MUVecAddr start _ fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c  -- | Allocate a MutableString of a specific size in bytes. new :: PrimMonad prim@@ -215,6 +167,18 @@     -> prim (MutableString (PrimState prim)) new n = MutableString `fmap` MVec.new n +newNative :: PrimMonad prim+          => CountOf Word8 -- ^ in number of bytes, not of elements.+          -> (MutableByteArray# (PrimState prim) -> prim a)+          -> prim (a, MutableString (PrimState prim))+newNative n f = second MutableString `fmap` MVec.newNative n f+ freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba {-# INLINE freeze #-}++freezeShrink :: PrimMonad prim+             => CountOf Word8+             -> MutableString (PrimState prim)+             -> prim String+freezeShrink n (MutableString mba) = String `fmap` C.unsafeFreezeShrink mba n

@@ -8,11 +8,9 @@ -- Most helpers are lowlevel and unsafe, don't use -- directly. {-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash                  #-} {-# LANGUAGE NoImplicitPrelude          #-} {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UnboxedTuples              #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE CPP                        #-} module Foundation.Primitive.UTF8.Helper@@ -20,46 +18,74 @@  import           Foundation.Internal.Base import           Foundation.Internal.Primitive-import           Foundation.Bits import           Foundation.Primitive.Types.OffsetSize-import           Foundation.Numerical-import           Foundation.Primitive.Types import           GHC.Prim import           GHC.Types import           GHC.Word --- same as nextAscii but with a ByteArray#-nextAsciiBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)-nextAsciiBA ba n = (# w, not (testBit w 7) #)-  where-    !w = primBaIndex ba n-{-# INLINE nextAsciiBA #-}+-- | Possible failure related to validating bytes of UTF8 sequences.+data ValidationFailure = InvalidHeader+                       | InvalidContinuation+                       | MissingByte+                       | BuildingFailure+                       deriving (Show,Eq,Typeable) --- same as nextAscii but with a ByteArray#-nextAsciiPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)-nextAsciiPtr (Ptr addr) n = (# w, not (testBit w 7) #)-  where !w = primAddrIndex addr n-{-# INLINE nextAsciiPtr #-}+instance Exception ValidationFailure --- | nextAsciiBa specialized to get a digit between 0 and 9 (included)-nextAsciiDigitBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)-nextAsciiDigitBA ba n = (# d, d < 0xa #)-  where !d = primBaIndex ba n - 0x30-{-# INLINE nextAsciiDigitBA #-}+-- mask an UTF8 continuation byte (stripping the leading 10 and returning 6 valid bits)+maskContinuation# :: Word# -> Word#+maskContinuation# v = and# v 0x3f##+{-# INLINE maskContinuation# #-} -nextAsciiDigitPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)-nextAsciiDigitPtr (Ptr addr) n = (# d, d < 0xa #)-  where !d = primAddrIndex addr n - 0x30-{-# INLINE nextAsciiDigitPtr #-}+-- mask a UTF8 header for 2 bytes encoding (110xxxxx and 5 valid bits)+maskHeader2# :: Word# -> Word#+maskHeader2# h = and# h 0x1f##+{-# INLINE maskHeader2# #-} -expectAsciiBA :: ByteArray# -> Offset8 -> Word8 -> Bool-expectAsciiBA ba n v = primBaIndex ba n == v-{-# INLINE expectAsciiBA #-}+-- mask a UTF8 header for 3 bytes encoding (1110xxxx and 4 valid bits)+maskHeader3# :: Word# -> Word#+maskHeader3# h = and# h 0xf##+{-# INLINE maskHeader3# #-} -expectAsciiPtr :: Ptr Word8 -> Offset8 -> Word8 -> Bool-expectAsciiPtr (Ptr ptr) n v = primAddrIndex ptr n == v-{-# INLINE expectAsciiPtr #-}+-- mask a UTF8 header for 3 bytes encoding (11110xxx and 3 valid bits)+maskHeader4# :: Word# -> Word#+maskHeader4# h = and# h 0x7##+{-# INLINE maskHeader4# #-} +or3# :: Word# -> Word# -> Word# -> Word#+or3# a b c = or# a (or# b c)+{-# INLINE or3# #-}++or4# :: Word# -> Word# -> Word# -> Word# -> Word#+or4# a b c d = or# (or# a b) (or# c d)+{-# INLINE or4# #-}++toChar# :: Word# -> Char+toChar# w = C# (chr# (word2Int# w))+{-# INLINE toChar# #-}++toChar1 :: Word8 -> Char+toChar1 (W8# w) = toChar# w++toChar2 :: Word8 -> Word8 -> Char+toChar2 (W8# w1) (W8# w2)=+    toChar# (or# (uncheckedShiftL# (maskHeader2# w1) 6#) (maskContinuation# w2))++toChar3 :: Word8 -> Word8 -> Word8 -> Char+toChar3 (W8# w1) (W8# w2) (W8# w3) =+    toChar# (or3# (uncheckedShiftL# (maskHeader3# w1) 12#)+                  (uncheckedShiftL# (maskContinuation# w2) 6#)+                  (maskContinuation# w3)+            )++toChar4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char+toChar4 (W8# w1) (W8# w2) (W8# w3) (W8# w4) =+    toChar# (or4# (uncheckedShiftL# (maskHeader4# w1) 18#)+                  (uncheckedShiftL# (maskContinuation# w2) 12#)+                  (uncheckedShiftL# (maskContinuation# w3) 6#)+                  (maskContinuation# w4)+            )+ -- | Different way to encode a Character in UTF8 represented as an ADT data UTF8Char =       UTF8_1 {-# UNPACK #-} !Word8@@ -117,6 +143,9 @@     | x < 0xF0  = CountOf 3 -- 0b11110000     | otherwise = CountOf 4 {-# INLINE skipNextHeaderValue #-}++headerIsAscii :: Word8 -> Bool+headerIsAscii x = x < 0x80  charToBytes :: Int -> Size8 charToBytes c

@@ -7,7 +7,6 @@ -- -- UTF8 lookup tables for fast continuation & nb bytes per header queries {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} module Foundation.Primitive.UTF8.Table     ( isContinuation     , getNbBytes

@@ -32,6 +32,8 @@     , words     , upper     , lower+    , replace+    , indices     ) where  import Foundation.String.UTF8

@@ -0,0 +1,57 @@+-- |+-- Module      : Foundation.String.Builder+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- String Builder+--+-- This is extremely bad implementation of a builder implementation+-- but provide a very similar API to the future fast implementation;+-- So, in the spirit of getting started and to be able to start using+-- the API, we don't wait for the fast implementation.+module Foundation.String.Builder+    ( Builder+    , emit+    , emitChar+    , toString+    ) where++import           Foundation.Internal.Base+--import           Foundation.Internal.Semigroup+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.String.UTF8                (String)+import qualified Foundation.String.UTF8 as S++data Builder = E String | T [Builder]++instance IsString Builder where+    fromString = E . fromString++--instance Semigroup Builder where+--    (<>) = append++instance Monoid Builder where+    mempty = empty+    mappend = append+    mconcat = concat++empty :: Builder+empty = T []++emit :: String -> Builder+emit s = E s++emitChar :: Char -> Builder+emitChar c = E (S.singleton c)++toString :: Builder -> String+toString = mconcat . flatten+  where+    flatten (E s) = [s]+    flatten (T l) = mconcat $ fmap flatten l++append :: Builder -> Builder -> Builder+append a b = T [a,b]++concat :: [Builder] -> Builder+concat = T

@@ -79,7 +79,7 @@       => Char            -- ^ expecting it to be a valid Ascii character.            -- otherwise this function will throw an exception-      -> Builder (UArray Word8) (MUArray Word8) Word8 st ()+      -> Builder (UArray Word8) (MUArray Word8) Word8 st err () write c     | c < toEnum 0x80 = builderAppend $ w8 c     | otherwise       = throw $ CharNotAscii c

@@ -22,6 +22,7 @@ import           Foundation.Array.Unboxed (UArray) import           Foundation.Array.Unboxed.Mutable (MUArray) import qualified Foundation.Array.Unboxed as Vec+import           Foundation.Monad.Exception  class Encoding encoding where     -- | the unit element use for the encoding.@@ -62,7 +63,7 @@                       -- ^ the unicode character to encode                   -> Builder (UArray (Unit encoding))                              (MUArray (Unit encoding))-                             (Unit encoding) st ()+                             (Unit encoding) st err ()  -- | helper to convert a given Array in a given encoding into an array -- with another encoding.@@ -80,7 +81,6 @@ -- convertFromTo :: ( PrimMonad st, Monad st                  , Encoding input, PrimType (Unit input)-                 , Exception (Error input)                  , Encoding output, PrimType (Unit output)                  )               => input@@ -89,9 +89,9 @@                 -- ^ Output's encoding type               -> UArray (Unit input)                 -- ^ the input raw array-              -> st (UArray (Unit output))+              -> st (Either (Offset (Unit input), Error input) (UArray (Unit output))) convertFromTo inputEncodingTy outputEncodingTy bytes-    | Vec.null bytes = return mempty+    | Vec.null bytes = return . return $ mempty     | otherwise      = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t)   where     lastUnit = Vec.length bytes@@ -99,5 +99,5 @@     loop off getter       | off .==# lastUnit = return ()       | otherwise = case encodingNext inputEncodingTy getter off of-          Left err -> throw err+          Left err -> mFail (off, err)           Right (c, noff) -> encodingWrite outputEncodingTy c >> loop noff getter

@@ -55,7 +55,7 @@  write :: (PrimMonad st, Monad st)       => Char-      -> Builder (UArray Word8) (MUArray Word8) Word8 st ()+      -> Builder (UArray Word8) (MUArray Word8) Word8 st err () write c@(C# ch)     | c <= toEnum 0xFF = builderAppend (W8# x)     | otherwise        = throw $ NotISO_8859_1 c

@@ -77,7 +77,7 @@  write :: (PrimMonad st, Monad st)       => Char-      -> Builder (UArray Word16) (MUArray Word16) Word16 st ()+      -> Builder (UArray Word16) (MUArray Word16) Word16 st err () write c     | c < toEnum 0xd800   = builderAppend $ w16 c     | c > toEnum 0x10000  = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2

@@ -47,7 +47,7 @@  write :: (PrimMonad st, Monad st)       => Char-      -> Builder (UArray Word32) (MUArray Word32) Word32 st ()+      -> Builder (UArray Word32) (MUArray Word32) Word32 st err () write c = builderAppend w32   where     !(C# ch) = c

@@ -61,7 +61,7 @@     ba <- buildByteArray addr     Vec.unsafeIndexer ba buildWithBytes   where-    buildWithBytes getAt = Vec.builderBuild 64 $ loopBuilder getAt (Offset 0)+    buildWithBytes getAt = Vec.builderBuild_ 64 (loopBuilder getAt (Offset 0))     loopBuilder getAt offset =         case bs of             [] -> internalError "ModifiedUTF8.fromModified"

@@ -14,7 +14,6 @@ -- The String data must contain UTF8 valid data. -- {-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash                  #-} {-# LANGUAGE NoImplicitPrelude          #-} {-# LANGUAGE TypeFamilies               #-}@@ -48,6 +47,7 @@     , splitOn     , sub     , elem+    , indices     , intersperse     , span     , break@@ -64,8 +64,10 @@     , sortBy     , filter     , reverse+    , replace     , builderAppend     , builderBuild+    , builderBuild_     , readInteger     , readIntegral     , readNatural@@ -87,6 +89,7 @@ import qualified Foundation.Array.Unboxed           as C import           Foundation.Array.Unboxed.ByteArray (MutableByteArray) import qualified Foundation.Array.Unboxed.Mutable   as MVec+import           Foundation.Class.Bifunctor import           Foundation.Internal.Base import           Foundation.Internal.Natural import           Foundation.Internal.MonadTrans@@ -95,12 +98,17 @@ import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Primitive.Types+import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Floating import           Foundation.Boot.Builder import           Foundation.Primitive.UTF8.Table import           Foundation.Primitive.UTF8.Helper import           Foundation.Primitive.UTF8.Base+import qualified Foundation.Primitive.UTF8.BA as PrimBA+import qualified Foundation.Primitive.UTF8.Addr as PrimAddr+import qualified Foundation.String.UTF8.BA as BackendBA+import qualified Foundation.String.UTF8.Addr as BackendAddr import           GHC.Prim import           GHC.ST import           GHC.Types@@ -121,14 +129,6 @@ import qualified Foundation.String.Encoding.UTF32      as Encoder import qualified Foundation.String.Encoding.ISO_8859_1 as Encoder --- | Possible failure related to validating bytes of UTF8 sequences.-data ValidationFailure = InvalidHeader-                       | InvalidContinuation-                       | MissingByte-                       deriving (Show,Eq,Typeable)--instance Exception ValidationFailure- -- | UTF8 Encoder data EncoderUTF8 = EncoderUTF8 @@ -146,50 +146,15 @@          -> Offset8          -> CountOf Word8          -> (Offset8, Maybe ValidationFailure)-validate ba ofsStart sz = runST (Vec.unsafeIndexer ba go)+validate array ofsStart sz = C.unsafeDewrap goBa goAddr array   where+    unTranslateOffset start = first (\e -> e `offsetSub` start)+    goBa ba start =+        unTranslateOffset start $ BackendBA.validate (start+end) ba (start + ofsStart)+    goAddr (Ptr addr) start =+        pure $ unTranslateOffset start $ BackendAddr.validate (start+end) addr (ofsStart + start)     end = ofsStart `offsetPlusE` sz -    go :: (Offset Word8 -> Word8) -> ST s (Offset Word8, Maybe ValidationFailure)-    go getIdx = return $ loop ofsStart-      where-        loop ofs-            | ofs > end  = error "validate: internal error: went pass offset"-            | ofs == end = (end, Nothing)-            | otherwise  =-                case {-# SCC "validate.one" #-} one ofs of-                    (nextOfs, Nothing)  -> loop nextOfs-                    (pos, Just failure) -> (pos, Just failure)--        one pos =-            case nbConts of-                0    -> (pos + 1, Nothing)-                0xff -> (pos, Just InvalidHeader)-                _ | (pos + 1) `offsetPlusE` nbContsE > end -> (pos, Just MissingByte)-                1    ->-                    let c1 = getIdx (pos + 1)-                     in if isContinuation c1-                            then (pos + 2, Nothing)-                            else (pos, Just InvalidContinuation)-                2 ->-                    let c1 = getIdx (pos + 1)-                        c2 = getIdx (pos + 2)-                     in if isContinuation c1 && isContinuation c2-                            then (pos + 3, Nothing)-                            else (pos, Just InvalidContinuation)-                3 ->-                    let c1 = getIdx (pos + 1)-                        c2 = getIdx (pos + 2)-                        c3 = getIdx (pos + 3)-                     in if isContinuation c1 && isContinuation c2 && isContinuation c3-                            then (pos + 4, Nothing)-                            else (pos, Just InvalidContinuation)-                _ -> error "internal error"-          where-            !h = getIdx pos-            !nbContsE@(CountOf nbConts) = CountOf $ getNbBytes h-    {-# INLINE go #-}- -- | Similar to 'validate' but works on a 'MutableByteArray' mutableValidate :: PrimMonad prim                 => MutableByteArray (PrimState prim)@@ -278,12 +243,12 @@  writeWithBuilder :: (PrimMonad st, Monad st)                  => Char-                 -> Builder (UArray Word8) (MVec.MUArray Word8) Word8 st ()-writeWithBuilder c =-    if      bool# (ltWord# x 0x80##   ) then encode1-    else if bool# (ltWord# x 0x800##  ) then encode2-    else if bool# (ltWord# x 0x10000##) then encode3-    else                                     encode4+                 -> Builder (UArray Word8) (MVec.MUArray Word8) Word8 st err ()+writeWithBuilder c+    | bool# (ltWord# x 0x80##   ) = encode1+    | bool# (ltWord# x 0x800##  ) = encode2+    | bool# (ltWord# x 0x10000##) = encode3+    | otherwise = encode4   where     !(I# xi) = fromEnum c     !x       = int2Word# xi@@ -390,7 +355,7 @@     {-# INLINE goVec #-}      goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8)-    goAddr !(Ptr ptr) !start = return $ loop start (Offset 0)+    goAddr (Ptr ptr) !start = return $ loop start (Offset 0)       where         !len = start `offsetPlusE` Vec.length ba         loop :: Offset Word8 -> Offset Char -> Offset Word8@@ -750,21 +715,23 @@ -- -- If empty, Nothing is returned unsnoc :: String -> Maybe (String, Char)-unsnoc s-    | null s    = Nothing-    | otherwise = case index s (sizeLastOffset $ length s) of-        Nothing -> Nothing-        Just c  -> Just (revDrop 1 s, c)+unsnoc s@(String arr)+    | sz == 0   = Nothing+    | otherwise =+        let (# c, idx #) = prev s (sizeAsOffset sz)+         in Just (String $ Vec.take (offsetAsSize idx) arr, c)+  where+    sz = size s  -- | Extract the First character of a string, and the String stripped of the first character. -- -- If empty, Nothing is returned uncons :: String -> Maybe (Char, String)-uncons s+uncons s@(String ba)     | null s    = Nothing-    | otherwise = case index s 0 of-          Nothing -> Nothing-          Just c  -> Just (c, drop 1 s)+    | otherwise =+        let (# c, idx #) = next s azero+         in Just (c, String $ Vec.drop (offsetAsSize idx) ba)  -- | Look for a predicate in the String and return the matched character, if any. find :: (Char -> Bool) -> String -> Maybe Char@@ -781,12 +748,21 @@                     False -> loop idx'  -- | Sort the character in a String using a specific sort function+--+-- TODO: optimise not going through a list sortBy :: (Char -> Char -> Ordering) -> String -> String sortBy sortF s = fromList $ Data.List.sortBy sortF $ toList s -- FIXME for tests  -- | Filter characters of a string using the predicate filter :: (Char -> Bool) -> String -> String-filter p s = fromList $ Data.List.filter p $ toList s+filter predicate (String arr) = runST $ do+    (finalSize, dst) <- newNative sz $ \mba ->+        case arr of+            C.UVecBA start _ _ ba -> BackendBA.copyFilter predicate sz mba ba start+            C.UVecAddr start _ fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start+    freezeShrink finalSize dst+  where+    !sz = C.length arr  -- | Reverse a string reverse :: String -> String@@ -820,6 +796,17 @@                 _  -> return () -- impossible             loop ms (si `offsetPlusE` nb) d +-- Finds where are the insertion points when we search for a `needle`+-- within an `haystack`.+indices :: String -> String -> [Offset8]+indices (String ned) (String hy) = Vec.indices ned hy++-- | Replace all the occurrencies of `needle` with `replacement` in+-- the `haystack` string.+replace :: String -> String -> String -> String+replace (String needle) (String replacement) (String haystack) =+  String $ Vec.replace needle replacement haystack+ -- | Return the nth character in a String -- -- Compared to an array, the string need to be scanned from the beginning@@ -860,17 +847,19 @@     deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded)  fromEncoderBytes :: ( Encoder.Encoding encoding-                    , Exception (Encoder.Error encoding)                     , PrimType (Encoder.Unit encoding)                     )                  => encoding                  -> UArray Word8                  -> (String, Maybe ValidationFailure, UArray Word8) fromEncoderBytes enc bytes =-    ( String $ runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes)-    , Nothing-    , mempty-    )+    case runST $ Encoder.convertFromTo enc EncoderUTF8 (Vec.recast bytes) of+        -- TODO: Don't swallow up specific error (second element of pair)+        -- TODO: Confused why all this recasting is necessary. I "typed hole"-ed my way to get this function to compile.  Feels like there should be a cleaner method.+        Left (off, _) ->+            let (b1, b2) = Vec.splitAt (offsetAsSize off) (Vec.recast bytes)+            in (String $ Vec.recast b1, Just BuildingFailure, Vec.recast b2)+        Right converted -> (String converted, Nothing, mempty)  -- | Convert a ByteArray to a string assuming a specific encoding. --@@ -901,6 +890,7 @@     toErr MissingByte         = Nothing     toErr InvalidHeader       = Just InvalidHeader     toErr InvalidContinuation = Just InvalidContinuation+    toErr BuildingFailure     = Just BuildingFailure  -- | Convert a UTF8 array of bytes to a String. --@@ -916,6 +906,8 @@     | otherwise    =         case validate bytes (Offset 0) (C.length bytes) of             (_, Nothing)                   -> (fromBytesUnsafe bytes, mempty)+            -- TODO: Should anything be done in the 'BuildingFailure' case?+            (_, Just BuildingFailure) -> error "fromBytesLenient: FIXME!"             (pos, Just MissingByte) ->                 let (b1,b2) = C.splitAt (offsetAsSize pos) bytes                  in (fromBytesUnsafe b1, b2)@@ -942,7 +934,7 @@ fromChunkBytes l = loop l   where     loop []         = []-    loop (bytes:[]) =+    loop [bytes]    =         case validate bytes (Offset 0) (C.length bytes) of             (_, Nothing)  -> [fromBytesUnsafe bytes]             (_, Just err) -> doErr err@@ -970,7 +962,10 @@                => encoding                -> UArray Word8                -> UArray Word8-toEncoderBytes enc bytes = Vec.recast (runST $ Encoder.convertFromTo EncoderUTF8 enc bytes)+toEncoderBytes enc bytes = Vec.recast $+  case runST $ Encoder.convertFromTo EncoderUTF8 enc bytes of+    Left _ -> error "toEncoderBytes: FIXME!"+    Right converted -> converted  -- | Convert a String to a bytearray in a specific encoding --@@ -996,8 +991,8 @@ words = fmap fromList . Prelude.words . toList  -- | Append a character to a String builder-builderAppend :: PrimMonad state => Char -> Builder String MutableString Word8 state ()-builderAppend c = Builder $ State $ \(i, st) ->+builderAppend :: PrimMonad state => Char -> Builder String MutableString Word8 state err ()+builderAppend c = Builder $ State $ \(i, st, e) ->     if offsetAsSize i + nbBytes >= chunkSize st         then do             cur      <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)@@ -1006,26 +1001,29 @@             return ((), (sizeAsOffset nbBytes, st { prevChunks     = cur : prevChunks st                                                   , prevChunksSize = offsetAsSize i + prevChunksSize st                                                   , curChunk       = newChunk-                                                  }))+                                                  }, e))         else do             writeUTF8Char (curChunk st) i utf8Char-            return ((), (i + sizeAsOffset nbBytes, st))+            return ((), (i + sizeAsOffset nbBytes, st, e))   where     utf8Char = asUTF8Char c     nbBytes  = numBytes utf8Char  -- | Create a new String builder using chunks of @sizeChunksI@-builderBuild :: PrimMonad m => Int -> Builder String MutableString Word8 m () -> m String+builderBuild :: PrimMonad m => Int -> Builder String MutableString Word8 m err () -> m (Either err String) builderBuild sizeChunksI sb     | sizeChunksI <= 3 = builderBuild 64 sb     | otherwise        = do-        first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks)-        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)-        -- Build final array-        let totalSize = prevChunksSize st + offsetAsSize i-        final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze-        return $ String final+        firstChunk         <- new sizeChunks+        ((), (i, st, e)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (CountOf 0) firstChunk sizeChunks, Nothing)+        case e of+          Just err -> return (Left err)+          Nothing -> do+            cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            -- Build final array+            let totalSize = prevChunksSize st + offsetAsSize i+            final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze+            return . Right . String $ final   where     sizeChunks = CountOf sizeChunksI @@ -1035,6 +1033,9 @@         Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz         fillFromEnd (end - sz) xs mba +builderBuild_ :: PrimMonad m => Int -> Builder String MutableString Word8 m () () -> m String+builderBuild_ sizeChunksI sb = either (\() -> internalError "impossible output") id <$> builderBuild sizeChunksI sb+ stringDewrap :: (ByteArray# -> Offset Word8 -> a)              -> (Ptr Word8 -> Offset Word8 -> ST s a)              -> String@@ -1052,14 +1053,14 @@   where     !sz = size str     withBa ba ofs =-        let negativeSign = expectAsciiBA ba ofs 0x2d+        let negativeSign = PrimBA.expectAscii ba ofs 0x2d             startOfs     = if negativeSign then succ ofs else ofs          in case decimalDigitsBA 0 ba endOfs startOfs of                 (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc                 _                                             -> Nothing       where !endOfs = ofs `offsetPlusE` sz-    withPtr ptr ofs = return $-        let negativeSign = expectAsciiPtr ptr ofs 0x2d+    withPtr (Ptr ptr) ofs = return $+        let negativeSign = PrimAddr.expectAscii ptr ofs 0x2d             startOfs     = if negativeSign then succ ofs else ofs          in case decimalDigitsPtr 0 ptr endOfs startOfs of                 (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc@@ -1079,7 +1080,7 @@     | sz == 0  = Nothing     | otherwise =         case decimalDigits 0 str 0 of-            (# acc, True, endOfs #) | endOfs > 0 -> Just $ acc+            (# acc, True, endOfs #) | endOfs > 0 -> Just acc             _                                    -> Nothing   where     !sz = size str@@ -1152,7 +1153,7 @@     !sz = size str      withBa ba stringStart =-        let !isNegative = expectAsciiBA ba stringStart 0x2d+        let !isNegative = PrimBA.expectAscii ba stringStart 0x2d          in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)       where         eofs = stringStart `offsetPlusE` sz@@ -1160,7 +1161,7 @@             case decimalDigitsBA 0 ba eofs startOfs of                 (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.'                 (# acc, False, endOfs #) | endOfs > startOfs ->-                    if expectAsciiBA ba endOfs 0x2e+                    if PrimBA.expectAscii ba endOfs 0x2e                         then consumeFloat isNegative acc (endOfs + 1)                         else consumeExponant isNegative acc 0 endOfs                 _                                            -> Nothing@@ -1177,22 +1178,22 @@             | startOfs == eofs = f isNegative integral floatingDigits Nothing             | otherwise        =                 -- consume 'E' or 'e'-                case nextAsciiBA ba startOfs of+                case PrimBA.nextAscii ba startOfs of                     (# 0x45, True #) -> consumeExponantSign (startOfs+1)                     (# 0x65, True #) -> consumeExponantSign (startOfs+1)                     (# _   , _    #) -> Nothing           where             consumeExponantSign ofs                 | ofs == eofs = Nothing-                | otherwise   = let exponentNegative = expectAsciiBA ba ofs 0x2d+                | otherwise   = let exponentNegative = PrimBA.expectAscii ba ofs 0x2d                                  in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs)              consumeExponantNumber exponentNegative ofs =                 case decimalDigitsBA 0 ba eofs ofs of                     (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc)                     _                                      -> Nothing-    withPtr ptr stringStart = return $-        let !isNegative = expectAsciiPtr ptr stringStart 0x2d+    withPtr (Ptr ptr) stringStart = return $+        let !isNegative = PrimAddr.expectAscii ptr stringStart 0x2d          in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)       where         eofs = stringStart `offsetPlusE` sz@@ -1200,7 +1201,7 @@             case decimalDigitsPtr 0 ptr eofs startOfs of                 (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.'                 (# acc, False, endOfs #) | endOfs > startOfs ->-                    if expectAsciiPtr ptr endOfs 0x2e+                    if PrimAddr.expectAscii ptr endOfs 0x2e                         then consumeFloat isNegative acc (endOfs + 1)                         else consumeExponant isNegative acc 0 endOfs                 _                                            -> Nothing@@ -1217,14 +1218,14 @@             | startOfs == eofs = f isNegative integral floatingDigits Nothing             | otherwise        =                 -- consume 'E' or 'e'-                case nextAsciiPtr ptr startOfs of+                case PrimAddr.nextAscii ptr startOfs of                     (# 0x45, True #) -> consumeExponantSign (startOfs+1)                     (# 0x65, True #) -> consumeExponantSign (startOfs+1)                     (# _   , _    #) -> Nothing           where             consumeExponantSign ofs                 | ofs == eofs = Nothing-                | otherwise   = let exponentNegative = expectAsciiPtr ptr ofs 0x2d+                | otherwise   = let exponentNegative = PrimAddr.expectAscii ptr ofs 0x2d                                  in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs)              consumeExponantNumber exponentNegative ofs =@@ -1285,7 +1286,7 @@     loop !acc !ofs         | ofs == endOfs = (# acc, True, ofs #)         | otherwise     =-            case nextAsciiDigitBA ba ofs of+            case PrimBA.nextAsciiDigit ba ofs of                 (# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)                 (# _, _ #)    -> (# acc, False, ofs #) {-# SPECIALIZE decimalDigitsBA :: Integer -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}@@ -1296,7 +1297,7 @@ -- | same as decimalDigitsBA specialized for ptr # decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)                  => acc-                 -> Ptr Word8+                 -> Addr#                  -> Offset Word8 -- end offset                  -> Offset Word8 -- start offset                  -> (# acc, Bool, Offset Word8 #)@@ -1305,13 +1306,13 @@     loop !acc !ofs         | ofs == endOfs = (# acc, True, ofs #)         | otherwise     =-            case nextAsciiDigitPtr ptr ofs of+            case PrimAddr.nextAsciiDigit ptr ofs of                 (# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)                 (# _, _ #)    -> (# acc, False, ofs #)-{-# SPECIALIZE decimalDigitsPtr :: Integer -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}-{-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Integer -> Addr# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Natural -> Addr# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Int -> Addr# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Word -> Addr# -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}  -- | Convert a 'String' to the upper-case equivalent. --   Does not properly support multicharacter Unicode conversions.@@ -1357,4 +1358,4 @@         | i == endOfs           = needle == haystackSub         | needle == haystackSub = True         | otherwise             = loop (i+1)-      where haystackSub = C.take needleLen $ C.drop i $ haystack+      where haystackSub = C.take needleLen $ C.drop i haystack

@@ -0,0 +1,86 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Foundation.String.UTF8.Addr+    ( copyFilter+    , validate+    ) where++import           GHC.Prim+import           GHC.ST+import           Foundation.Internal.Base+import           Foundation.Numerical+import           Foundation.Primitive.Types.OffsetSize++import qualified Foundation.Primitive.UTF8.BA   as PrimBA+import qualified Foundation.Primitive.UTF8.Addr as PrimBackend+import           Foundation.Primitive.UTF8.Helper+import           Foundation.Primitive.UTF8.Table++copyFilter :: (Char -> Bool)+           -> CountOf Word8+           -> MutableByteArray# s+           -> PrimBackend.Immutable+           -> Offset Word8+           -> ST s (CountOf Word8)+copyFilter predicate !sz dst src start = loop (Offset 0) start+  where+    !end = start `offsetPlusE` sz+    loop !d !s+        | s == end  = pure (offsetAsSize d)+        | otherwise =+            let !h = PrimBackend.primIndex src s+             in case headerIsAscii h of+                    True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)+                         | otherwise             -> loop d (s + Offset 1)+                    False ->+                        case PrimBackend.next src s of+                            (# c, s' #) | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'+                                        | otherwise   -> loop d s'++validate :: Offset Word8+         -> PrimBackend.Immutable+         -> Offset Word8+         -> (Offset Word8, Maybe ValidationFailure)+validate end ba ofsStart = loop ofsStart+  where+    loop !ofs+        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)+        | ofs == end = (end, Nothing)+        | otherwise  =+            let !h = PrimBackend.primIndex ba ofs in+            case headerIsAscii h of+                True  -> loop (ofs + Offset 1)+                False ->+                    case one (CountOf $ getNbBytes h) ofs of+                        (nextOfs, Nothing)  -> loop nextOfs+                        (pos, Just failure) -> (pos, Just failure)++    one (CountOf 0xff) pos = (pos, Just InvalidHeader)+    one nbConts pos+        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    in if isContinuation c1+                        then (pos + Offset 2, Nothing)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                     in if isContinuation c1 && isContinuation c2+                            then (pos + Offset 3, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf 3 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                        c3 = PrimBackend.primIndex ba (pos + Offset 3)+                     in if isContinuation c1 && isContinuation c2 && isContinuation c3+                            then (pos + Offset 4, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf _ -> error "internal error"

@@ -0,0 +1,86 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Foundation.String.UTF8.BA+    ( copyFilter+    , validate+    ) where++import           GHC.Prim+import           GHC.ST+import           Foundation.Internal.Base+import           Foundation.Numerical+import           Foundation.Primitive.Types.OffsetSize++import qualified Foundation.Primitive.UTF8.BA as PrimBA+import qualified Foundation.Primitive.UTF8.BA as PrimBackend+import           Foundation.Primitive.UTF8.Helper+import           Foundation.Primitive.UTF8.Table++copyFilter :: (Char -> Bool)+           -> CountOf Word8+           -> MutableByteArray# s+           -> PrimBackend.Immutable+           -> Offset Word8+           -> ST s (CountOf Word8)+copyFilter predicate !sz dst src start = loop (Offset 0) start+  where+    !end = start `offsetPlusE` sz+    loop !d !s+        | s == end  = pure (offsetAsSize d)+        | otherwise =+            let !h = PrimBackend.primIndex src s+             in case headerIsAscii h of+                    True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1)+                         | otherwise             -> loop d (s + Offset 1)+                    False ->+                        case PrimBackend.next src s of+                            (# c, s' #) | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'+                                        | otherwise   -> loop d s'++validate :: Offset Word8+         -> PrimBackend.Immutable+         -> Offset Word8+         -> (Offset Word8, Maybe ValidationFailure)+validate end ba ofsStart = loop ofsStart+  where+    loop !ofs+        | ofs > end  = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end)+        | ofs == end = (end, Nothing)+        | otherwise  =+            let !h = PrimBackend.primIndex ba ofs in+            case headerIsAscii h of+                True  -> loop (ofs + Offset 1)+                False ->+                    case one (CountOf $ getNbBytes h) ofs of+                        (nextOfs, Nothing)  -> loop nextOfs+                        (pos, Just failure) -> (pos, Just failure)++    one (CountOf 0xff) pos = (pos, Just InvalidHeader)+    one nbConts pos+        | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte)+        | otherwise =+            case nbConts of+                CountOf 1 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                    in if isContinuation c1+                        then (pos + Offset 2, Nothing)+                        else (pos, Just InvalidContinuation)+                CountOf 2 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                     in if isContinuation c1 && isContinuation c2+                            then (pos + Offset 3, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf 3 ->+                    let c1 = PrimBackend.primIndex ba (pos + Offset 1)+                        c2 = PrimBackend.primIndex ba (pos + Offset 2)+                        c3 = PrimBackend.primIndex ba (pos + Offset 3)+                     in if isContinuation c1 && isContinuation c2 && isContinuation c3+                            then (pos + Offset 4, Nothing)+                            else (pos, Just InvalidContinuation)+                CountOf _ -> error "internal error"

@@ -35,33 +35,62 @@ size_CTimeT :: CSize size_CTimeT = #const sizeof(time_t) -#if defined __APPLE__ +------------------------------------------------------------------------+#ifdef __APPLE__+ #include <Availability.h> +-- in OSX 10.12, clock_* API family is defined #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12+#define FOUNDATION_SYSTEM_API_NO_CLOCK+#endif -#define CLOCK_REALTIME 0-#define CLOCK_MONOTONIC 1-#define CLOCK_PROCESS_CPUTIME_ID 2-#define CLOCK_THREAD_CPUTIME_ID 3+#endif +------------------------------------------------------------------------+#ifdef _WIN32 #define FOUNDATION_SYSTEM_API_NO_CLOCK- #endif +------------------------------------------------------------------------+#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK++#define FOUNDATION_CLOCK_REALTIME 0+#define FOUNDATION_CLOCK_MONOTONIC 1+#define FOUNDATION_CLOCK_PROCESS_CPUTIME_ID 2+#define FOUNDATION_CLOCK_THREAD_CPUTIME_ID 3+ #endif -sysTime_CLOCK_REALTIME-    , sysTime_CLOCK_MONOTONIC :: CClockId++sysTime_CLOCK_REALTIME :: CClockId+#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK+sysTime_CLOCK_REALTIME = (#const FOUNDATION_CLOCK_REALTIME)+#else sysTime_CLOCK_REALTIME = (#const CLOCK_REALTIME)+#endif++sysTime_CLOCK_MONOTONIC :: CClockId+#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK+sysTime_CLOCK_MONOTONIC = (#const FOUNDATION_CLOCK_MONOTONIC)+#else sysTime_CLOCK_MONOTONIC = (#const CLOCK_MONOTONIC)+#endif  sysTime_CLOCK_PROCESS_CPUTIME_ID :: CClockId+#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK+sysTime_CLOCK_PROCESS_CPUTIME_ID = (#const FOUNDATION_CLOCK_PROCESS_CPUTIME_ID)+#else sysTime_CLOCK_PROCESS_CPUTIME_ID = (#const CLOCK_PROCESS_CPUTIME_ID)+#endif  sysTime_CLOCK_THREAD_CPUTIME_ID :: CClockId+#ifdef FOUNDATION_SYSTEM_API_NO_CLOCK+sysTime_CLOCK_THREAD_CPUTIME_ID = (#const FOUNDATION_CLOCK_THREAD_CPUTIME_ID)+#else sysTime_CLOCK_THREAD_CPUTIME_ID = (#const CLOCK_THREAD_CPUTIME_ID)+#endif  #ifdef CLOCK_MONOTONIC_RAW sysTime_CLOCK_MONOTONIC_RAW :: CClockId

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}  module Foundation.Time.StopWatch     ( StopWatchPrecise@@ -54,7 +53,7 @@ initPrecise :: (Word64, Word64) initPrecise = unsafePerformIO $ do     mti <- newPinned (sizeOfCSize size_MachTimebaseInfo)-    p   <- mutableGetAddr mti +    p   <- mutableGetAddr mti     sysMacos_timebase_info (castPtr p)     let p32 = castPtr p :: Ptr Word32     !n <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_numer)@@ -92,7 +91,7 @@     let p64 = castPtr p :: Ptr Word64     end   <- peek p64     start <- peek (p64 `ptrPlus` 8)-    pure $ NanoSeconds $ ((end - start) * secondInNano `div` initPrecise)+    pure $ NanoSeconds ((end - start) * secondInNano `div` initPrecise) #elif defined(darwin_HOST_OS)     end <- sysMacos_absolute_time     pure $ NanoSeconds $ case initPrecise of

@@ -5,7 +5,6 @@ -- -- An implementation of a timing framework ---{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Timing     ( Timing(..)     , Measure(..)

@@ -9,6 +9,11 @@  Documentation: [foundation on hackage](http://hackage.haskell.org/package/foundation) +ZuriHac 2017+============++_temporary chapter_. You can contact us on [Gitter](https://gitter.im/haskell-foundation/foundation). We are also room **1.261** if you are looking for us (you can find **Nei Mitchell** and **Vincent Hanquez**).+ Goals ===== @@ -67,14 +72,9 @@ How to contribute ================= -Any contributions is welcome, but a short list includes:+Contribution guide can be found+[here](http://haskell-foundation.readthedocs.io/en/latest/contributing/). -* Improve the code base-* Report an issue-* Fix an issue-* Improve the documentation-* Make tutorial on how to use foundation-* Make your project use foundation instead of base, report the missing coverage (IO, types, etc.), or what functionality is missing to make a succesful transition  Profiling ---------

@@ -9,6 +9,7 @@     , reverse     , decimal     , double+    , decodeUtf8     ) where  import Prelude (undefined, Either(..))@@ -22,6 +23,7 @@ filter _    = undefined reverse     = undefined any         = undefined+decodeUtf8  = undefined  decimal :: Text -> Either a (b, c) decimal = undefined

@@ -9,6 +9,7 @@ import Foundation import Foundation.Collection import Foundation.String.Read+import Foundation.String import BenchUtil.Common import BenchUtil.RefData @@ -19,6 +20,7 @@ import qualified Data.ByteString.Char8 as ByteString (readInt, readInteger) import qualified Data.Text as Text import qualified Data.Text.Read as Text+import qualified Data.Text.Encoding as Text #else import qualified Fake.ByteString as ByteString import qualified Fake.Text as Text@@ -35,6 +37,7 @@     , benchReverse     , benchFilter     , benchRead+    , benchFromUTF8Bytes     ]   where     diffTextString :: (String -> a)@@ -51,6 +54,21 @@         s = fromList dat         t = Text.pack dat +    diffToTextString :: (UArray Word8 -> String)+                     -> (ByteString.ByteString -> Text.Text)+                     -> [Word8]+                     -> [Benchmark]+    diffToTextString foundationBench textBench dat =+        [ bench "String" $ whnf foundationBench s+#ifdef BENCH_ALL+        , bench "Text"   $ whnf textBench t+#endif+        ]+      where+        s = fromList dat+        t = ByteString.pack dat++     diffBsTextString :: (String -> a)                    -> (Text.Text -> b)                    -> (ByteString.ByteString -> c)@@ -92,7 +110,7 @@             ) [ 10, 100, 800 ]      benchBuildable = bgroup "Buildable" $-        fmap (\(n, dat) -> bench n $ toString (\es -> runST $ build 128 $ Prelude.mapM_ append es) dat)+        fmap (\(n, dat) -> bench n $ toString (\es -> runST $ build_ 128 $ Prelude.mapM_ append es) dat)             allDat      benchReverse = bgroup "Reverse" $@@ -103,7 +121,7 @@         fmap (\(n, dat) -> bgroup n $ diffTextString (filter (> 'b')) (Text.filter (> 'b')) dat)             allDat -    benchRead = bgroup "Read" $+    benchRead = bgroup "Read"         [ bgroup "Integer"             [ bgroup "10000" (diffTextString stringReadInteger textReadInteger (toList $ show 10000))             , bgroup "1234567891234567890" (diffTextString stringReadInteger textReadInteger (toList $ show 1234567891234567890))@@ -131,6 +149,9 @@         stringReadInteger :: String -> Integer         stringReadInteger = maybe undefined id . readIntegral +    benchFromUTF8Bytes = bgroup "FromUTF8" $+        fmap (\(n, dat) -> bgroup n $ diffToTextString (fst . fromBytes UTF8) (Text.decodeUtf8) dat)+             (fmap (second (toList . toBytes UTF8 . fromList)) allDat)      toString :: ([Char] -> String) -> [Char] -> Benchmarkable     toString = whnf

@@ -2,6 +2,14 @@  #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK +typedef enum {+	FOUNDATION_CLOCK_REALTIME,+	FOUNDATION_CLOCK_MONOTONIC,+	FOUNDATION_CLOCK_PROCESS_CPUTIME_ID,+	FOUNDATION_CLOCK_THREAD_CPUTIME_ID+} foundation_clockid_t;++ #ifdef FOUNDATION_SYSTEM_MACOS #include <time.h> #include <mach/clock.h>@@ -13,27 +21,19 @@  */  -typedef enum {-	CLOCK_REALTIME,-	CLOCK_MONOTONIC,-	CLOCK_PROCESS_CPUTIME_ID,-	CLOCK_THREAD_CPUTIME_ID-} clockid_t;-- static mach_timebase_info_data_t timebase = {0,0};  int foundation_time_clock_getres(unsigned int clockid, struct timespec *timespec) { 	switch (clockid) {-	/* clockid = 1 (CLOCK_MONOTONIC), or any other value */-	case CLOCK_MONOTONIC:+	/* clockid = 1 (FOUNDATION_CLOCK_MONOTONIC), or any other value */+	case FOUNDATION_CLOCK_MONOTONIC: 		if (timebase.denom == 0) mach_timebase_info(&timebase); 		timespec->tv_sec = 0; 		timespec->tv_nsec = timebase.numer / timebase.denom; 		break;-	/* clockid = 0 (CLOCK_REALTIME), or any other value */-	case CLOCK_REALTIME:+	/* clockid = 0 (FOUNDATION_CLOCK_REALTIME), or any other value */+	case FOUNDATION_CLOCK_REALTIME: 		return -1; 	} 	return -1;@@ -59,19 +59,60 @@ 	case CLOCK_PROCESS_CPUTIME_ID: 		break; #endif-	case CLOCK_MONOTONIC:+	case FOUNDATION_CLOCK_MONOTONIC: 		host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &cclock); 		clock_get_time(cclock, &mts); 		mach_port_deallocate(mach_task_self(), cclock); 		timespec->tv_sec = mts.tv_sec; 		timespec->tv_nsec = mts.tv_nsec; 		break;-	case CLOCK_REALTIME:+	case FOUNDATION_CLOCK_REALTIME: 		host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); 		clock_get_time(cclock, &mts); 		mach_port_deallocate(mach_task_self(), cclock); 		timespec->tv_sec = mts.tv_sec; 		timespec->tv_nsec = mts.tv_nsec;+		break;+	default:+		return -1;+	}+	return 0;+}++#elif defined(FOUNDATION_SYSTEM_WINDOWS)++#include <windows.h>++// from:+// https://stackoverflow.com/questions/5404277/porting-clock-gettime-to-windows++struct timespec { long tv_sec; long tv_nsec; }; //header part++#define BILLION                             (1E9)++int foundation_time_clock_getres(unsigned int clockid, struct timespec *timespec)+{+}++int foundation_time_clock_gettime(unsigned int clockid, struct timespec *ct)+{+	LARGE_INTEGER count;+	static LARGE_INTEGER counts_per_sec = { .QuadPart = -1 };++	switch (clockid) {+	case FOUNDATION_CLOCK_MONOTONIC:+		if (counts_per_sec.QuadPart == -1) {+			if (0 == QueryPerformanceFrequency(&counts_per_sec)) {+				counts_per_sec.QuadPart = 0;+			}+		}++		if ((NULL == ct) || (counts_per_sec.QuadPart <= 0) || (0 == QueryPerformanceCounter(&count))) {+			return -1;+		}++		ct->tv_sec = count.QuadPart / counts_per_sec.QuadPart;+		ct->tv_nsec = ((count.QuadPart % counts_per_sec.QuadPart) * BILLION) / counts_per_sec.QuadPart; 		break; 	default: 		return -1;

@@ -1,5 +1,5 @@ name:                foundation-version:             0.0.10+version:             0.0.11 synopsis:            Alternative prelude with batteries and no dependencies description:     A custom prelude with no dependencies apart from base.@@ -78,6 +78,7 @@                      Foundation.String                      Foundation.String.ASCII                      Foundation.String.Read+                     Foundation.String.Builder                      Foundation.IO                      Foundation.IO.FileMap                      Foundation.IO.Terminal@@ -115,6 +116,8 @@                      Foundation.Boot.List                      Foundation.String.Internal                      Foundation.String.UTF8+                     Foundation.String.UTF8.BA+                     Foundation.String.UTF8.Addr                      Foundation.String.Encoding.Encoding                      Foundation.String.Encoding.UTF16                      Foundation.String.Encoding.UTF32@@ -138,6 +141,7 @@                      Foundation.Collection.InnerFunctor                      Foundation.Collection.Collection                      Foundation.Collection.Copy+                     Foundation.Collection.NonEmpty                      Foundation.Collection.Sequential                      Foundation.Collection.Keyed                      Foundation.Collection.Indexed@@ -186,6 +190,8 @@                      Foundation.Primitive.UTF8.Table                      Foundation.Primitive.UTF8.Helper                      Foundation.Primitive.UTF8.Base+                     Foundation.Primitive.UTF8.BA+                     Foundation.Primitive.UTF8.Addr                      Foundation.Primitive.Runtime                      Foundation.Primitive.Imports                      Foundation.Monad.MonadIO

@@ -140,10 +140,10 @@         ]     , collectionProperties "DList a" (Proxy :: Proxy (DList Word8)) arbitrary     , Group "Array"-      [ matrixToGroup "Block" $ primTypesMatrixArbitrary $ \prx arb ->-            \s -> collectionProperties ("Block " <> s) (functorProxy (Proxy :: Proxy Block) prx) arb-      , matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb ->-            \s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy UArray) prx) arb+      [ matrixToGroup "Block" $ primTypesMatrixArbitrary $ \prx arb s ->+            collectionProperties ("Block " <> s) (functorProxy (Proxy :: Proxy Block) prx) arb+      , matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb s ->+            collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy UArray) prx) arb       , Group "Boxed"         [ collectionProperties "Array(W8)"  (Proxy :: Proxy (Array Word8))  arbitrary         , collectionProperties "Array(W16)" (Proxy :: Proxy (Array Word16)) arbitrary@@ -169,8 +169,8 @@         ]       ]     , Group "ChunkedUArray"-      [ matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb ->-            \s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy ChunkedUArray) prx) arb+      [ matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb s ->+            collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy ChunkedUArray) prx) arb       ]     , testRandom     ]

@@ -236,7 +236,7 @@     , Property "init" $ withNonEmptyElements $ \els -> toList (init $ fromListNonEmptyP proxy els) === init els     , Property "splitOn" $ withElements2E $ \(l, ch) ->          fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l-    , testSplitOn proxy (\_ -> True) mempty+    , testSplitOn proxy (const True) mempty     , Property "intercalate c (splitOn (c ==) col) == col" $ withElements2E $ \(c, ch) ->         intercalate [ch] (splitOn (== ch) c) === c     , Property "intercalate c (splitOn (c ==) (col ++ [c]) == (col ++ [c])" $ withElements2E $ \(c, ch) ->

@@ -203,7 +203,7 @@     , testProperty "init" $ withNonEmptyElements $ \els -> toList (init $ fromListNonEmptyP proxy els) === init els     , testProperty "splitOn" $ withElements2E $ \(l, ch) ->          fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l-    , testSplitOn proxy (\_ -> True) mempty+    , testSplitOn proxy (const True) mempty     , testProperty "intercalate c (splitOn (c ==) col) == col" $ withElements2E $ \(c, ch) ->         intercalate [ch] (splitOn (== ch) c) === c     , testProperty "intercalate c (splitOn (c ==) (col ++ [c]) == (col ++ [c])" $ withElements2E $ \(c, ch) ->

@@ -24,8 +24,8 @@  testEncoding :: EncodedString -> String -> [TestTree] testEncoding (EncodedString encoding ba) expected =-    [ testCase (show encoding <> " -> UTF8") $ testFromBytes-    , testCase ("UTF8 -> " <> show encoding) $ testToBytes+    [ testCase (show encoding <> " -> UTF8") testFromBytes+    , testCase ("UTF8 -> " <> show encoding) testToBytes     ]   where     testFromBytes :: Assertion

@@ -31,6 +31,6 @@     ]  testUUID = testGroup "UUID"-    [ testProperty "show" $ show (UUID.nil) === "00000000-0000-0000-0000-000000000000"+    [ testProperty "show" $ show UUID.nil === "00000000-0000-0000-0000-000000000000"     , testProperty "show-bin" $ fmap show (UUID.fromBinary (fromList [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16])) === Just "100f0e0d-0c0b-0a09-0807-060504030201"     ]

@@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} module Test.Foundation.Number     ( testNumber

@@ -5,7 +5,7 @@   ( testParsers   ) where -import Foundation+import           Foundation import           Foundation.Parser import qualified Foundation.Parser as P @@ -14,7 +14,7 @@  data TestCaseRes a     = TestCaseOk String a-    | TestCaseMore (Maybe String) (TestCaseRes a)+    | TestCaseMore String (TestCaseRes a)     | TestCaseFail   deriving (Show) @@ -26,11 +26,11 @@ parseTestCase buff parser = check (parse parser buff) check :: (Show a, Eq a) => Result String a -> TestCaseRes a -> Assertion check r e = case (r, e) of-    (ParseOK remain a, TestCaseOk eRemain ea) -> do+    (ParseOk remain a, TestCaseOk eRemain ea) -> do         assertEqual "remaining buffer" eRemain remain         assertEqual "returned value" ea a     (ParseMore fr, TestCaseMore mb res') -> check (fr mb) res'-    (ParseFail _, TestCaseFail) -> return ()+    (ParseFailed _, TestCaseFail) -> return ()     _ -> assertFailure $ toList $             "parseTestCase failed: "                 <> "expected: " <> show e <> " "@@ -42,51 +42,51 @@     [ testGroup "element"         [ testCase "Ok" $ parseTestCase "a" (element 'a') (TestCaseOk "" ())         , testCase "Fail" $ parseTestCase "b" (element 'a') TestCaseFail-        , testCase "MoreOk" $ parseTestCase "" (element 'a') (TestCaseMore (Just "a") (TestCaseOk "" ()))-        , testCase "MoreFail" $ parseTestCase "" (element 'a') (TestCaseMore Nothing TestCaseFail)+        , testCase "MoreOk" $ parseTestCase "a" (element 'a' >> element 'a') (TestCaseMore "a" (TestCaseOk "" ()))+        , testCase "MoreFail" $ parseTestCase "a" (element 'a' >> element 'a') (TestCaseMore mempty TestCaseFail)         ]     , testGroup "elements"         [ testCase "Ok" $ parseTestCase "abc" (elements "ab") (TestCaseOk "c" ())         , testCase "Fail" $ parseTestCase "ac" (elements "ab") TestCaseFail-        , testCase "MoreOk" $ parseTestCase "a" (elements "abc") (TestCaseMore (Just "bc") (TestCaseOk "" ()))-        , testCase "MoreMoreOk" $ parseTestCase "a" (elements "abc") (TestCaseMore (Just "b") $ TestCaseMore (Just "c") (TestCaseOk "" ()))-        , testCase "MoreMoreFail" $ parseTestCase "a" (elements "abc") (TestCaseMore (Just "b") $ TestCaseMore Nothing TestCaseFail)+        , testCase "MoreOk" $ parseTestCase "a" (elements "abc") (TestCaseMore "bc" (TestCaseOk "" ()))+        , testCase "MoreMoreOk" $ parseTestCase "a" (elements "abc") (TestCaseMore "b" $ TestCaseMore "c" (TestCaseOk "" ()))+        , testCase "MoreMoreFail" $ parseTestCase "a" (elements "abc") (TestCaseMore "b" $ TestCaseMore mempty TestCaseFail)         ]     , testGroup "anyElement"         [ testCase "OK" $ parseTestCase "a"   anyElement (TestCaseOk "" 'a')         , testCase "OkRemains" $ parseTestCase "abc" anyElement (TestCaseOk "bc" 'a')-        , testCase "MoreOk" $ parseTestCase ""    anyElement $ TestCaseMore (Just "abc")(TestCaseOk "bc" 'a')-        , testCase "MoreFail" $ parseTestCase ""    anyElement $ TestCaseMore Nothing TestCaseFail+        , testCase "MoreOk" $ parseTestCase "a" (anyElement *> anyElement) $ TestCaseMore "abc" (TestCaseOk "bc" 'a')+        , testCase "MoreFail" $ parseTestCase "a" (anyElement <* anyElement) $ TestCaseMore mempty TestCaseFail         ]     , testGroup "take"         [ testCase "OK" $ parseTestCase "a" (P.take 1) (TestCaseOk "" "a")         , testCase "OkRemains" $ parseTestCase "abc" (P.take 2) (TestCaseOk "c" "ab")-        , testCase "MoreOk" $ parseTestCase "" (P.take 2) $ TestCaseMore (Just "abc")(TestCaseOk "c" "ab")-        , testCase "MoreFail" $ parseTestCase "a" (P.take 2) $ TestCaseMore Nothing TestCaseFail+        , testCase "MoreOk" $ parseTestCase "a" (P.take 2) $ TestCaseMore "bc" (TestCaseOk "c" "ab")+        , testCase "MoreFail" $ parseTestCase "a" (P.take 2) $ TestCaseMore mempty TestCaseFail         ]     , testGroup "takeWhile"-        [ testCase "OK" $ parseTestCase "a " (takeWhile (' ' /=)) (TestCaseOk " " "a")-        , testCase "OkRemains" $ parseTestCase "ab bc" (takeWhile (' ' /=)) (TestCaseOk " bc" "ab")-        , testCase "MoreOk" $ parseTestCase "ab" (takeWhile (' ' /=)) $ TestCaseMore (Just "cd ")(TestCaseOk " " "abcd")-        , testCase "MoreFail" $ parseTestCase "aa" (takeWhile (' ' /=)) $ TestCaseMore Nothing TestCaseFail+        [ testCase "OK" $ parseTestCase "a " (P.takeWhile (' ' /=)) (TestCaseOk " " "a")+        , testCase "OkRemains" $ parseTestCase "ab bc" (P.takeWhile (' ' /=)) (TestCaseOk " bc" "ab")+        , testCase "MoreOk" $ parseTestCase "ab" (P.takeWhile (' ' /=)) $ TestCaseMore "cd " (TestCaseOk " " "abcd")+        , testCase "MoreEmptyOK" $ parseTestCase "aa" (P.takeWhile (' ' /=)) $ TestCaseMore mempty (TestCaseOk "" "aa")         ]     , testGroup "takeAll"-        [ testCase "OK" $ parseTestCase "abc" takeAll (TestCaseMore Nothing $ TestCaseOk "" "abc")+        [ testCase "OK" $ parseTestCase "abc" takeAll (TestCaseMore mempty $ TestCaseOk "" "abc")         ]     , testGroup "skip"         [ testCase "OK" $ parseTestCase "a" (skip 1) (TestCaseOk "" ())         , testCase "OkRemains" $ parseTestCase "abc" (skip 2) (TestCaseOk "c" ())-        , testCase "MoreOk" $ parseTestCase "" (skip 2) $ TestCaseMore (Just "abc")(TestCaseOk "c" ())-        , testCase "MoreFail" $ parseTestCase "a" (skip 2) $ TestCaseMore Nothing TestCaseFail+        , testCase "MoreOk" $ parseTestCase "a" (skip 2) $ TestCaseMore "bc" (TestCaseOk "c" ())+        , testCase "MoreFail" $ parseTestCase "a" (skip 2) $ TestCaseMore mempty TestCaseFail         ]     , testGroup "skipWhile"         [ testCase "OK" $ parseTestCase "a " (skipWhile (' ' /=)) (TestCaseOk " " ())         , testCase "OkRemains" $ parseTestCase "ab bc" (skipWhile (' ' /=)) (TestCaseOk " bc" ())-        , testCase "MoreOk" $ parseTestCase "ab" (skipWhile (' ' /=)) $ TestCaseMore (Just "cd ")(TestCaseOk " " ())-        , testCase "MoreFail" $ parseTestCase "aa" (skipWhile (' ' /=)) $ TestCaseMore Nothing TestCaseFail+        , testCase "MoreOk" $ parseTestCase "ab" (skipWhile (' ' /=)) $ TestCaseMore "cd " (TestCaseOk " " ())+        , testCase "MoreEmptyOk" $ parseTestCase "aa" (skipWhile (' ' /=)) $ TestCaseMore mempty (TestCaseOk "" ())         ]     , testGroup "skipAll"-        [ testCase "OK" $ parseTestCase "abc" skipAll (TestCaseMore Nothing $ TestCaseOk "abc" ())+        [ testCase "OK" $ parseTestCase "abc" skipAll (TestCaseMore mempty $ TestCaseOk "" ())         ]     , testGroup "optional"         [ testCase "Nothing" $ parseTestCase "aaa" (optional $ elements "bbb") (TestCaseOk "aaa" Nothing)@@ -96,6 +96,11 @@         [ testCase "many elements" $ parseTestCase "101010\0"             (many ((element '1' >> pure True) <|> (element '0' >> pure False) ) )             (TestCaseOk "\0" [True, False, True, False, True, False])+        ]+    , testGroup "parseOnly"+        [ testCase "takeWhile" $ case parseOnly (P.takeWhile (' ' /=)) ("abc" :: [Char]) of+            Right "abc" -> return ()+            _           -> error "failed"         ]     ] 

@@ -94,7 +94,7 @@         accEnt ent pr             | pr > 0.0  = ent + (pr * xlog (1 Prelude./ pr))             | otherwise = ent-        xlog v = Prelude.logBase 10 v * (Prelude.log 10 Prelude./ Prelude.log 2)+        xlog v = Prelude.logBase 10 v * (Prelude.logBase 2 10)          accMeanChi :: (Word64, Double) -> (Int, Word64) -> (Word64, Double)         accMeanChi (dataSum, chiSq) (i, ccount) =

@@ -7,9 +7,13 @@     ( testStringRefs     ) where +import Control.Monad (replicateM)+ import Foundation import Foundation.String import Foundation.String.ASCII (AsciiString)+import Control.Exception+import Data.Either  import Test.Tasty import Test.Tasty.QuickCheck@@ -31,8 +35,8 @@            , testGroup "Encoding Sample2" (testEncodings sample2)            ]     , testGroup "ASCII" $-        [  testCollection "Sequential" (Proxy :: Proxy AsciiString) genAsciiChar-        ]+        [  testCollection "Sequential" (Proxy :: Proxy AsciiString) genAsciiChar ]+        <> testAsciiStringCases     ]  testStringCases :: [TestTree]@@ -49,25 +53,83 @@                         (s, merr, nextBa) = fromBytes UTF8 ba'                      in (nextBa, merr : errs, s : acc) -                (remainingBa, allErrs, chunkS) = foldl reconstruct (mempty, [], []) $ chunks randomInts wholeBA+                (remainingBa, allErrs, chunkS) = foldl' reconstruct (mempty, [], []) $ chunks randomInts wholeBA              in (catMaybes allErrs === []) .&&. (remainingBa === mempty) .&&. (mconcat (reverse chunkS) === wholeS)         ]+    , testGroup "replace" [+          testCase "indices '' 'bb' should raise an error" $ do+            res <- try (evaluate $ indices "" "bb")+            case res of+              (Left (_ :: SomeException)) -> return ()+              Right _ -> fail "Expecting an error to be thrown, but it did not."+        , testCase "indices 'aa' 'bb' == []" $ do+            indices "aa" "bb" @?= []+        , testCase "indices 'aa' 'aabbccabbccEEaaaaabb' is correct" $ do+            indices "aa" "aabbccabbccEEaaaaabb" @?= [Offset 0,Offset 13,Offset 15]+        , testCase "indices 'aa' 'aaccaadd' is correct" $ do+            indices "aa" "aaccaadd" @?= [Offset 0,Offset 4]+        , testCase "replace '' 'bb' 'foo' raises an error" $ do+            (res :: Either SomeException String) <- try (evaluate $ replace "" "bb" "foo")+            assertBool "Expecting an error to be thrown, but it did not." (isLeft res)+        , testCase "replace 'aa' 'bb' '' == ''" $ do+            replace "aa" "bb" "" @?= ""+        , testCase "replace 'aa' '' 'aabbcc' == 'aabbcc'" $ do+            replace "aa" "" "aabbcc" @?= "bbcc"+        , testCase "replace 'aa' 'bb' 'aa' == 'bb'" $ do+            replace "aa" "bb" "aa" @?= "bb"+        , testCase "replace 'aa' 'bb' 'aabb' == 'bbbb'" $ do+            replace "aa" "bb" "aabb" @?= "bbbb"+        , testCase "replace 'aa' 'bb' 'aaccaadd' == 'bbccbbdd'" $ do+            replace "aa" "bb" "aaccaadd" @?= "bbccbbdd"+        , testCase "replace 'aa' 'LongLong' 'aaccaadd' == 'LongLongccLongLongdd'" $ do+            replace "aa" "LongLong" "aaccaadd" @?= "LongLongccLongLongdd"+        , testCase "replace 'aa' 'bb' 'aabbccabbccEEaaaaabb' == 'bbbbccabbccEEbbbbabb'" $ do+            replace "aa" "bb" "aabbccabbccEEaaaaabb" @?= "bbbbccabbccEEbbbbabb"+        , testCase "replace 'å' 'ä' 'ååññ' == 'ääññ'" $ do+            replace "å" "ä" "ååññ" @?= "ääññ"+                          ]     , testGroup "Cases"         [ testGroup "Invalid-UTF8"-            [ testCase "ff" $ expectFromBytesErr ("", Just InvalidHeader, 0) (fromList [0xff])-            , testCase "80" $ expectFromBytesErr ("", Just InvalidHeader, 0) (fromList [0x80])-            , testCase "E2 82 0C" $ expectFromBytesErr ("", Just InvalidContinuation, 0) (fromList [0xE2,0x82,0x0c])-            , testCase "30 31 E2 82 0C" $ expectFromBytesErr ("01", Just InvalidContinuation, 2) (fromList [0x30,0x31,0xE2,0x82,0x0c])+            [ testCase "ff" $ expectFromBytesErr UTF8 ("", Just InvalidHeader, 0) (fromList [0xff])+            , testCase "80" $ expectFromBytesErr UTF8 ("", Just InvalidHeader, 0) (fromList [0x80])+            , testCase "E2 82 0C" $ expectFromBytesErr UTF8 ("", Just InvalidContinuation, 0) (fromList [0xE2,0x82,0x0c])+            , testCase "30 31 E2 82 0C" $ expectFromBytesErr UTF8 ("01", Just InvalidContinuation, 2) (fromList [0x30,0x31,0xE2,0x82,0x0c])             ]         ]     ]-  where-    expectFromBytesErr (expectedString,expectedErr,positionErr) ba = do-        let (s', merr, ba') = fromBytes UTF8 ba-        assertEqual "error" expectedErr merr-        assertEqual "remaining" (drop positionErr ba) ba'-        assertEqual "string" expectedString (toList s') +testAsciiStringCases :: [TestTree]+testAsciiStringCases =+    [ testGroup "Validation-ASCII7"+        [ testProperty "fromBytes . toBytes == valid" $ \l ->+             let s = fromList . fromLStringASCII $ l+             in (fromBytes ASCII7 $ toBytes ASCII7 s) === (s, Nothing, mempty)+        , testProperty "Streaming" $ \(l, randomInts) ->+            let wholeS  = fromList . fromLStringASCII $ l+                wholeBA = toBytes ASCII7 wholeS+                reconstruct (prevBa, errs, acc) ba =+                    let ba' = prevBa `mappend` ba+                        (s, merr, nextBa) = fromBytes ASCII7 ba'+                     in (nextBa, merr : errs, s : acc)++                (remainingBa, allErrs, chunkS) = foldl' reconstruct (mempty, [], []) $ chunks randomInts wholeBA+             in (catMaybes allErrs === []) .&&. (remainingBa === mempty) .&&. (mconcat (reverse chunkS) === wholeS)+        ]+    , testGroup "Cases"+        [ testGroup "Invalid-ASCII7"+            [ testCase "ff" $ expectFromBytesErr ASCII7 ("", Just BuildingFailure, 0) (fromList [0xff])+            ]+        ]+    ]++expectFromBytesErr :: Encoding -> ([Char], Maybe ValidationFailure, CountOf Word8) -> UArray Word8 -> IO ()+expectFromBytesErr enc (expectedString,expectedErr,positionErr) ba = do+    let x = fromBytes enc ba+        (s', merr, ba') = x+    assertEqual "error" expectedErr merr+    assertEqual "remaining" (drop positionErr ba) ba'+    assertEqual "string" expectedString (toList s')+ chunks :: Sequential c => RandomList -> c -> [c] chunks (RandomList randomInts) = loop (randomInts <> [1..])   where@@ -80,3 +142,11 @@                      in c1 : loop rs c2                 [] ->                     loop randomInts c++newtype LStringASCII = LStringASCII { fromLStringASCII :: LString }+    deriving (Show, Eq, Ord)++instance Arbitrary LStringASCII where+    arbitrary = do+        n <- choose (0,200)+        LStringASCII <$> replicateM n (toEnum <$> choose (1, 127))

@@ -24,5 +24,5 @@         let (CountOf szElem) = size (Proxy :: Proxy e)             nbBytes = szElem * (let (CountOf c) = length l in c)         ptr <- mallocBytes nbBytes-        forM_ (zip [0..] l) $ \(o, e) -> pokeOff ptr o e-        toFinalPtr ptr (\p -> free p)+        forM_ (zip [0..] l) $ uncurry (pokeOff ptr)+        toFinalPtr ptr free

@@ -130,7 +130,7 @@               => Proxy a -> Gen (Element a) -> Gen (Small Int) -> [TestTree] testBuildable proxy genElement genChunkSize =     [ testProperty "build s . mapM_ append == id" $ withElementsAndChunkSize $ \(l, Small s) ->-        runST (build s (Prelude.mapM_ append l)) `asProxyTypeOf` proxy == fromListP proxy l+        runST (build_ s (Prelude.mapM_ append l)) `asProxyTypeOf` proxy == fromListP proxy l     ]   where     withElementsAndChunkSize = forAll ((,) <$> generateListOfElement genElement <*> genChunkSize)@@ -222,7 +222,7 @@     [ testArrayRefs     , testChunkedUArrayRefs     , Bits.tests-    , testCollection "Bitmap"  (Proxy :: Proxy (Bitmap))  arbitrary+    , testCollection "Bitmap"  (Proxy :: Proxy Bitmap)  arbitrary     , testStringRefs     , testGroup "VFS"         [ testGroup "FilePath" $ testCaseFilePath <> (testPath (arbitrary :: Gen FilePath))