foundation 0.0.3 → 0.0.4

raw patch · 82 files changed

+3148/−420 lines, 82 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Foundation.hs +8/−2
• Foundation/Array/Bitmap.hs +2/−0
• Foundation/Array/Boxed.hs +85/−125
• Foundation/Array/Chunked/Unboxed.hs +2/−0
• Foundation/Array/Internal.hs +2/−0
• Foundation/Array/Unboxed.hs +70/−13
• Foundation/Array/Unboxed/ByteArray.hs +2/−3
• Foundation/Array/Unboxed/Mutable.hs +75/−0
• Foundation/Bits.hs +1/−0
• Foundation/Boot/Builder.hs +26/−0
• Foundation/Boot/List.hs +21/−0
• Foundation/Class/Storable.hs +62/−0
• Foundation/Collection.hs +2/−0
• Foundation/Collection/Buildable.hs +37/−68
• Foundation/Collection/Collection.hs +34/−1
• Foundation/Collection/Copy.hs +18/−0
• Foundation/Collection/Element.hs +5/−0
• Foundation/Collection/Foldable.hs +5/−0
• Foundation/Collection/Indexed.hs +18/−0
• Foundation/Collection/InnerFunctor.hs +7/−0
• Foundation/Collection/List.hs +1/−1
• Foundation/Collection/Mutable.hs +17/−0
• Foundation/Collection/Sequential.hs +45/−0
• Foundation/Collection/Zippable.hs +20/−3
• Foundation/Conduit.hs +81/−0
• Foundation/Conduit/Internal.hs +390/−0
• Foundation/Hashing/FNV.hs +4/−0
• Foundation/Hashing/SipHash.hs +1/−1
• Foundation/IO.hs +1/−0
• Foundation/IO/File.hs +10/−4
• Foundation/Internal/ByteSwap.hs +82/−0
• Foundation/Internal/Environment.hs +37/−2
• Foundation/Internal/Error.hs +38/−0
• Foundation/Internal/NumLiteral.hs +8/−0
• Foundation/Math/Trigonometry.hs +14/−0
• Foundation/Monad.hs +41/−0
• Foundation/Monad/Exception.hs +37/−4
• Foundation/Monad/Identity.hs +7/−0
• Foundation/Monad/Reader.hs +7/−1
• Foundation/Monad/State.hs +2/−1
• Foundation/Network/IPv4.hs +90/−0
• Foundation/Network/IPv6.hs +256/−0
• Foundation/Numerical.hs +6/−0
• Foundation/Numerical/Multiplicative.hs +3/−0
• Foundation/Numerical/Number.hs +1/−0
• Foundation/Numerical/Primitives.hs +3/−1
• Foundation/Parser.hs +107/−2
• Foundation/Primitive.hs +6/−0
• Foundation/Primitive/Base16.hs +45/−0
• Foundation/Primitive/Endianness.hs +84/−0
• Foundation/Primitive/FinalPtr.hs +22/−0
• Foundation/Primitive/Monad.hs +2/−2
• Foundation/Primitive/Types.hs +35/−0
• Foundation/String/ASCII.hs +2/−0
• Foundation/String/Encoding/ASCII7.hs +4/−3
• Foundation/String/Encoding/Encoding.hs +14/−13
• Foundation/String/Encoding/ISO_8859_1.hs +4/−3
• Foundation/String/Encoding/UTF16.hs +6/−5
• Foundation/String/Encoding/UTF32.hs +4/−3
• Foundation/String/ModifiedUTF8.hs +3/−4
• Foundation/String/UTF8.hs +247/−137
• Foundation/System/Bindings.hs +10/−0
• Foundation/System/Bindings/Hs.hs +7/−0
• Foundation/System/Bindings/Linux.hsc +101/−0
• Foundation/System/Bindings/Macos.hsc +19/−0
• Foundation/System/Bindings/Posix.hsc +345/−0
• Foundation/System/Bindings/PosixDef.hsc +25/−0
• Foundation/System/Bindings/Windows.hs +2/−0
• foundation.cabal +27/−2
• tests/Test/Data/Network.hs +74/−0
• tests/Test/Foundation/Array.hs +21/−1
• tests/Test/Foundation/Bits.hs +0/−1
• tests/Test/Foundation/ChunkedUArray.hs +21/−1
• tests/Test/Foundation/Collection.hs +6/−0
• tests/Test/Foundation/Conduit.hs +46/−0
• tests/Test/Foundation/Misc.hs +28/−0
• tests/Test/Foundation/Network/IPv4.hs +40/−0
• tests/Test/Foundation/Network/IPv6.hs +55/−0
• tests/Test/Foundation/Parser.hs +6/−5
• tests/Test/Foundation/Storable.hs +30/−2
• tests/Test/Utils/Foreign.hs +7/−5
• tests/Tests.hs +9/−1

@@ -27,7 +27,7 @@     , Prelude.either     , Prelude.flip     , Prelude.const-    , Prelude.error+    , Foundation.Internal.Error.error     , Foundation.IO.Terminal.putStr     , Foundation.IO.Terminal.putStrLn     --, print@@ -98,6 +98,7 @@     , (<>)       -- ** Collection     , Collection(..)+    , Sequential(..)     , NonEmpty     , nonEmpty       -- ** Folds@@ -134,6 +135,7 @@     , Foundation.Partial.partial     , Foundation.Partial.PartialError     , Foundation.Partial.fromPartial+    , Foundation.Internal.Base.ifThenElse       -- ** Old Prelude Strings as [Char] with bridge back and forth     , LString     ) where@@ -152,12 +154,14 @@ import           Data.Int (Int8, Int16, Int32, Int64) import           Foundation.String (String) import           Foundation.Array (UArray, Array, PrimType)-import           Foundation.Collection (Collection(..), NonEmpty, nonEmpty, Foldable(..))+import           Foundation.Collection (Collection(..), Sequential(..), NonEmpty, nonEmpty, Foldable(..)) import qualified Foundation.IO.Terminal  import           GHC.Exts (IsString(..)) import           Foundation.Internal.IsList+import qualified Foundation.Internal.Base (ifThenElse) import qualified Foundation.Internal.Proxy+import qualified Foundation.Internal.Error  import qualified Foundation.Numerical import qualified Foundation.Partial@@ -177,6 +181,8 @@ import qualified Data.List  import           Data.Monoid ((<>))++default (Prelude.Integer, Prelude.Double)  -- | Alias to Prelude String ([Char]) for compatibility purpose type LString = Prelude.String

@@ -89,6 +89,8 @@     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 instance C.Sequential Bitmap where     take = take     drop = drop

@@ -14,6 +14,7 @@     ( Array     , MArray     , empty+    , length     , copy     , copyAt     , unsafeCopyAtRO@@ -23,7 +24,38 @@     , unsafeThaw     , freeze     , unsafeWrite+    , unsafeRead     , unsafeIndex+    , write+    , read+    , index+    , singleton+    , null+    , take+    , drop+    , splitAt+    , revTake+    , revDrop+    , revSplitAt+    , splitOn+    , sub+    , intersperse+    , span+    , break+    , cons+    , snoc+    , uncons+    , unsnoc+    -- , findIndex+    , sortBy+    , filter+    , reverse+    , find+    , foldl'+    , foldr+    , foldl+    , builderAppend+    , builderBuild     ) where  import           GHC.Prim@@ -36,10 +68,9 @@ import           Foundation.Primitive.Types import           Foundation.Primitive.Monad import           Foundation.Array.Common-import qualified Foundation.Collection as C-import qualified Foundation.Collection.Buildable as CB+import           Foundation.Boot.Builder+import qualified Foundation.Boot.List as List import qualified Prelude-import qualified Data.List  -- | Array of a data Array a = Array {-# UNPACK #-} !(Offset a)@@ -77,123 +108,11 @@ instance Ord a => Ord (Array a) where     compare = vCompare -type instance C.Element (Array ty) = ty- instance IsList (Array ty) where     type Item (Array ty) = ty     fromList = vFromList     toList = vToList -instance C.InnerFunctor (Array ty)--instance C.Foldable (Array ty) where-    foldl = aFoldl-    foldr = aFoldr-    foldl' = aFoldl'--instance C.Collection (Array ty) where-    null = null-    length = length-    elem e = Data.List.elem e . toList-    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO-    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO-instance C.Sequential (Array ty) where-    take = take-    drop = drop-    splitAt = splitAt-    revTake = revTake-    revDrop = revDrop-    revSplitAt = revSplitAt-    splitOn = splitOn-    break = break-    intersperse = intersperse-    span = span-    reverse = reverse-    filter = filter-    unsnoc = unsnoc-    uncons = uncons-    snoc = snoc-    cons = cons-    find = find-    sortBy = sortBy-    singleton = fromList . (:[])--instance C.MutableCollection (MArray ty) where-    type MutableFreezed (MArray ty) = Array ty-    type MutableKey (MArray ty) = Int-    type MutableValue (MArray ty) = ty--    thaw = thaw-    freeze = freeze-    unsafeThaw = unsafeThaw-    unsafeFreeze = unsafeFreeze--    mutNew n = new (Size n)-    mutUnsafeWrite = unsafeWrite-    mutUnsafeRead = unsafeRead-    mutWrite = write-    mutRead = read--instance C.IndexedCollection (Array ty) where-    (!) l n-        | n < 0 || n >= length l = Nothing-        | otherwise              = Just $ index l n-    findIndex predicate c = loop 0-      where-        !len = length c-        loop i-            | i == len  = Nothing-            | otherwise =-                if predicate (unsafeIndex c i) then Just i else Nothing--instance C.Zippable (Array ty) where-  zipWith f as bs = runST $ CB.build 64 $ go f (toList as) (toList bs)-    where-      go _  []       _        = return ()-      go _  _        []       = return ()-      go f' (a':as') (b':bs') = CB.append (f' a' b') >> go f' as' bs'--instance C.BoxedZippable (Array ty)--instance CB.Buildable (Array ty) where-  type Mutable (Array ty) = MArray ty-  type Step (Array ty) = ty--  append v = CB.Builder $ State $ \(i, st) ->-      if offsetAsSize i == CB.chunkSize st-          then do-              cur      <- unsafeFreeze (CB.curChunk st)-              newChunk <- new (CB.chunkSize st)-              unsafeWrite newChunk 0 v-              return ((), (Offset 1, st { CB.prevChunks     = cur : CB.prevChunks st-                                        , CB.prevChunksSize = CB.chunkSize st + CB.prevChunksSize st-                                        , CB.curChunk       = newChunk-                                        }))-          else do-              let (Offset i') = i-              unsafeWrite (CB.curChunk st) i' v-              return ((), (i + Offset 1, st))-  {-# INLINE append #-}--  build sizeChunksI ab-    | sizeChunksI <= 0 = CB.build 64 ab-    | otherwise        = do-        first         <- new sizeChunks-        ((), (i, st)) <- runState (CB.runBuilder ab) (Offset 0, CB.BuildingState [] (Size 0) first sizeChunks)-        cur           <- unsafeFreezeShrink (CB.curChunk st) (offsetAsSize i)-        -- Build final array-        let totalSize = CB.prevChunksSize st + offsetAsSize i-        new totalSize >>= fillFromEnd totalSize (cur : CB.prevChunks st) >>= unsafeFreeze-    where-      sizeChunks = Size sizeChunksI--      fillFromEnd _   []     mua = return mua-      fillFromEnd !end (x:xs) mua = do-          let sz = lengthSize x-          unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz-          fillFromEnd (end - sz) xs mua-  {-# INLINE build #-}- -- | return the numbers of elements in a mutable array mutableLength :: MArray ty st -> Int mutableLength (MArray _ (Size len) _) = len@@ -405,7 +324,7 @@ vFromList :: [a] -> Array a vFromList l = runST (new len >>= loop 0 l)   where-    len = Size $ C.length l+    len = Size $ List.length l     loop _ []     ma = unsafeFreeze ma     loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma @@ -566,9 +485,15 @@ mapIndex f a = create (length a) (\i -> f i $ unsafeIndex a i) -} -cons ::  ty -> Array ty -> Array ty+singleton :: ty -> Array ty+singleton e = runST $ do+    a <- new 1+    unsafeWrite a 0 e+    unsafeFreeze a++cons :: ty -> Array ty -> Array ty cons e vec-    | len == Size 0 = C.singleton e+    | len == Size 0 = singleton e     | otherwise     = runST $ do         mv <- new (len + Size 1)         unsafeWrite mv 0 e@@ -579,7 +504,7 @@  snoc ::  Array ty -> ty -> Array ty snoc vec e-    | len == Size 0 = C.singleton e+    | len == Size 0 = singleton e     | otherwise     = runST $ do         mv <- new (len + Size 1)         unsafeCopyAtRO mv (Offset 0) vec (Offset 0) len@@ -677,26 +602,61 @@     len = length a     toEnd i = unsafeIndex a (len - i - 1) -aFoldl :: (a -> ty -> a) -> a -> Array ty -> a-aFoldl f initialAcc vec = loop 0 initialAcc+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)) -aFoldr :: (ty -> a -> a) -> a -> Array ty -> a-aFoldr f initialAcc vec = loop 0+foldr :: (ty -> a -> a) -> a -> Array ty -> a+foldr f initialAcc vec = loop 0   where     len = length vec     loop !i         | i == len  = initialAcc         | otherwise = unsafeIndex vec i `f` loop (i+1) -aFoldl' :: (a -> ty -> a) -> a -> Array ty -> a-aFoldl' f initialAcc vec = loop 0 initialAcc+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))++builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state ()+builderAppend v = Builder $ State $ \(i, st) ->+    if offsetAsSize i == chunkSize st+        then do+            cur      <- unsafeFreeze (curChunk st)+            newChunk <- new (chunkSize st)+            unsafeWrite newChunk 0 v+            return ((), (Offset 1, st { prevChunks     = cur : prevChunks st+                                      , prevChunksSize = chunkSize st + prevChunksSize st+                                      , curChunk       = newChunk+                                      }))+        else do+            let (Offset i') = i+            unsafeWrite (curChunk st) i' v+            return ((), (i + Offset 1, st))++builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m () -> m (Array ty)+builderBuild sizeChunksI ab+    | sizeChunksI <= 0 = builderBuild 64 ab+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+        -- Build final array+        let totalSize = prevChunksSize st + offsetAsSize i+        new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+  where+    sizeChunks = Size sizeChunksI++    fillFromEnd _   []     mua = return mua+    fillFromEnd !end (x:xs) mua = do+        let sz = lengthSize x+        unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz+        fillFromEnd (end - sz) xs mua

@@ -59,6 +59,8 @@     elem   = elem     minimum = minimum     maximum = maximum+    all p = Data.List.all p . toList+    any p = Data.List.any p . toList  instance PrimType ty => C.Sequential (ChunkedUArray ty) where     take = take

@@ -14,7 +14,9 @@ module Foundation.Array.Internal     ( UArray(..)     , fromForeignPtr+    , withPtr     , recast+    , toHexadecimal     ) where  import           Foundation.Array.Unboxed

@@ -80,6 +80,9 @@     , foldl'     , foreignMem     , fromForeignPtr+    , builderAppend+    , builderBuild+    , toHexadecimal     ) where  import           GHC.Prim@@ -93,13 +96,16 @@ import           Foundation.Internal.Primitive import           Foundation.Internal.Proxy import           Foundation.Internal.Types+import           Foundation.Internal.MonadTrans+import qualified Foundation.Primitive.Base16 as Base16 import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.Utils import           Foundation.Array.Common-import           Foundation.Array.Unboxed.Mutable+import           Foundation.Array.Unboxed.Mutable hiding (sub) import           Foundation.Numerical+import           Foundation.Boot.Builder import qualified Data.List  -- | An array of type built on top of GHC primitive.@@ -338,18 +344,18 @@  -- | Create a pinned array that is filled by a 'filler' function (typically an IO call like hGetBuf) createFromIO :: PrimType ty-             => Int                -- ^ the size of the array-             -> (Ptr ty -> IO Int) -- ^ filling function that+             => Size ty                  -- ^ the size of the array+             -> (Ptr ty -> IO (Size ty)) -- ^ filling function that              -> IO (UArray ty) createFromIO size filler     | size == 0 = return empty     | otherwise = do-        mba <- newPinned (Size size)+        mba <- newPinned size         r   <- withMutablePtr mba $ \p -> filler p         case r of             0             -> return empty -- make sure we don't keep our array referenced by using empty             _ | r < 0     -> error "filler returned negative number"-              | otherwise -> unsafeFreezeShrink mba (Size r)+              | otherwise -> unsafeFreezeShrink mba r  ----------------------------------------------------------------------- -- higher level collection implementation@@ -504,14 +510,6 @@     sz           = primSizeInBytes (vectorProxyTy vec)     !(Offset os) = offsetOfE sz start -withMutablePtr :: (PrimMonad prim, PrimType ty)-               => MUArray ty (PrimState prim)-               -> (Ptr ty -> prim a)-               -> prim a-withMutablePtr muvec f = do-    v <- unsafeFreeze muvec-    withPtr v f- recast :: (PrimType a, PrimType b) => UArray a -> UArray b recast = recast_ Proxy Proxy   where@@ -870,3 +868,62 @@     loop i !acc         | 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) ->+    if offsetAsSize i == chunkSize st+        then do+            cur      <- unsafeFreeze (curChunk st)+            newChunk <- new (chunkSize st)+            unsafeWrite newChunk 0 v+            return ((), (Offset 1, st { prevChunks     = cur : prevChunks st+                                      , prevChunksSize = chunkSize st + prevChunksSize st+                                      , curChunk       = newChunk+                                      }))+        else do+            let Offset i' = i+            unsafeWrite (curChunk st) i' v+            return ((), (i + Offset 1, st))++builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m () -> m (UArray ty)+builderBuild sizeChunksI ab+    | sizeChunksI <= 0 = builderBuild 64 ab+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+        -- Build final array+        let totalSize = prevChunksSize st + offsetAsSize i+        new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+  where+      sizeChunks = Size sizeChunksI++      fillFromEnd _   []     mua = return mua+      fillFromEnd !end (x:xs) mua = do+          let sz = lengthSize x+          unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz+          fillFromEnd (end - sz) xs mua++toHexadecimal :: PrimType ty => UArray ty -> UArray Word8+toHexadecimal ba+    | len == Size 0 = empty+    | otherwise     = runST $ do+        ma <- new (len `scale` 2)+        unsafeIndexer b8 (go ma)+        unsafeFreeze ma+  where+    b8 = unsafeRecast ba+    !len = lengthSize b8+    !endOfs = Offset 0 `offsetPlusE` len++    go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s ()+    go !ma !getAt = loop 0 0+      where+        loop !dIdx !sIdx+            | sIdx == endOfs = return ()+            | otherwise      = do+                let !(W8# !w)      = getAt sIdx+                    (# wHi, wLo #) = Base16.convertByte w+                unsafeWrite ma dIdx     (W8# wHi)+                unsafeWrite ma (dIdx+1) (W8# wLo)+                loop (dIdx + 2) (sIdx+1)

@@ -11,7 +11,6 @@ import Foundation.Array.Unboxed.Mutable import Foundation.Numerical import Control.Monad (forM_)-import qualified Foundation.Collection as C  -- | Mutable Byte Array alias type MutableByteArray st = MUArray Word8 st@@ -19,7 +18,7 @@ mutableByteArraySet :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> prim () mutableByteArraySet mba val = do     -- naive haskell way. TODO: call memset or a 32-bit/64-bit method-    forM_ [0..(len-1)] $ \i -> C.mutUnsafeWrite mba i val+    forM_ [0..(len-1)] $ \i -> unsafeWrite mba i val   where     len = mutableLength mba @@ -29,7 +28,7 @@     | offset > len || offset+size > len = throw (OutOfBound OOB_MemSet (offset+size) len)     | otherwise =         -- TODO same as mutableByteArraySet-        forM_ [offset..(offset+size-1)] $ \i -> C.mutUnsafeWrite mba i val+        forM_ [offset..(offset+size-1)] $ \i -> unsafeWrite mba i val   where     len = mutableLength mba 

@@ -12,6 +12,7 @@ -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-} module Foundation.Array.Unboxed.Mutable     ( MUArray(..)     -- * Property queries@@ -24,12 +25,14 @@     , newNative     , mutableForeignMem     , copyAt+    , sub     -- , copyAddr     -- * Reading and Writing cells     , unsafeWrite     , unsafeRead     , write     , read+    , withMutablePtr     ) where  import           GHC.Prim@@ -66,6 +69,9 @@ sizeInMutableBytesOfContent = primSizeInBytes . mutableArrayProxyTy {-# INLINE sizeInMutableBytesOfContent #-} +mvectorProxyTy :: MUArray ty s -> Proxy ty+mvectorProxyTy _ = Proxy+ -- | read a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.@@ -130,6 +136,9 @@                 !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz         {-# INLINE newFake #-} +empty :: (PrimMonad prim, PrimType ty) => prim (MUArray ty (PrimState prim))+empty = newUnpinned 0+ -- | Create a new mutable array of size @n. -- -- When memory for a new array is allocated, we decide if that memory region@@ -199,6 +208,26 @@         | i == endIndex = return ()         | otherwise     = unsafeRead src i >>= unsafeWrite dst d >> loop (Offset $ d+1) (Offset $ i+1) +sub :: (PrimMonad prim, PrimType ty)+    => MUArray ty (PrimState prim)+    -> Int -- The number of elements to drop ahead+    -> Int -- Then the number of element to retain+    -> prim (MUArray ty (PrimState prim))+sub (MUVecMA start sz pstatus mba) dropElems' takeElems+    | takeElems <= 0 = empty+    | resultEmpty    = empty+    | otherwise      = return $ MUVecMA (start `offsetPlusE` dropElems) (min (Size takeElems) (sz - dropElems)) pstatus mba+  where+    dropElems = max 0 (Size dropElems')+    resultEmpty = dropElems >= sz+sub (MUVecAddr start sz addr) dropElems' takeElems+    | takeElems <= 0 = empty+    | resultEmpty    = empty+    | otherwise      = return $ MUVecAddr (start `offsetPlusE` dropElems) (min (Size takeElems) (sz - dropElems)) addr+  where+    dropElems = max 0 (Size dropElems')+    resultEmpty = dropElems >= sz+ {- copyAddr :: (PrimMonad prim, PrimType ty)          => MUArray ty (PrimState prim) -- ^ destination array@@ -219,3 +248,49 @@ mutableLength :: PrimType ty => MUArray ty st -> Int mutableLength (MUVecMA _ (Size end) _ _) = end mutableLength (MUVecAddr _ (Size end) _) = end++withMutablePtrHint :: (PrimMonad prim, PrimType ty)+                   => Bool+                   -> Bool+                   -> MUArray ty (PrimState prim)+                   -> (Ptr ty -> prim a)+                   -> prim a+withMutablePtrHint _ _ vec@(MUVecAddr start _ fptr)  f =+    withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))+  where+    sz           = primSizeInBytes (mvectorProxyTy vec)+    !(Offset os) = offsetOfE sz start+withMutablePtrHint skipCopy skipCopyBack vec@(MUVecMA start vecSz pstatus a) f+    | isPinned pstatus = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os)+    | otherwise        = do+        trampoline <- newPinned vecSz+        if not skipCopy+            then copyAt trampoline 0 vec 0 vecSz+            else pure ()+        r <- withMutablePtr trampoline f+        if not skipCopyBack+            then copyAt vec 0 trampoline 0 vecSz+            else pure ()+        pure r+  where+    !(Offset os) = offsetOfE sz start+    sz           = primSizeInBytes (mvectorProxyTy vec)++    mutableByteArrayContent :: PrimMonad prim => MutableByteArray# (PrimState prim) -> prim (Ptr ty)+    mutableByteArrayContent mba = primitive $ \s1 ->+        case unsafeFreezeByteArray# mba s1 of+            (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)++-- | Create a pointer on the beginning of the mutable array+-- and call a function 'f'.+--+-- The mutable buffer can be mutated by the 'f' function+-- and the change will be reflected in the mutable array+--+-- If the mutable array is unpinned, a trampoline buffer+-- is created and the data is only copy when 'f' return.+withMutablePtr :: (PrimMonad prim, PrimType ty)+               => MUArray ty (PrimState prim)+               -> (Ptr ty -> prim a)+               -> prim a+withMutablePtr = withMutablePtrHint False False

@@ -2,6 +2,7 @@ module Foundation.Bits     ( (.<<.)     , (.>>.)+    , Bits(..)     , alignRoundUp     , alignRoundDown     ) where

@@ -0,0 +1,26 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Foundation.Boot.Builder+    ( Builder(..)+    , BuildingState(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.MonadTrans+import           Foundation.Internal.Types+import           Foundation.Primitive.Monad++newtype Builder collection mutCollection step state a = Builder+    { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state)) state a }+    deriving (Functor, Applicative, Monad)++-- | The in-progress state of a building operation.+--+-- The previous buffers are in reverse order, and+-- this contains the current buffer and the state of+-- progress packing the elements inside.+data BuildingState collection mutCollection step state = BuildingState+    { prevChunks     :: [collection]+    , prevChunksSize :: !(Size step)+    , curChunk       :: mutCollection state+    , chunkSize      :: !(Size step)+    }

@@ -0,0 +1,21 @@+module Foundation.Boot.List+    ( length+    , sum+    ) where++import Foundation.Internal.Base+import Foundation.Numerical.Additive++-- | Compute the size of the list+length :: [a] -> Int+length []     = 0+length (_:xs) = succ (length xs)++-- | Sum the element in a list+sum :: Additive n => [n] -> n+sum []     = azero+sum (i:is) = loop i is+  where+    loop !acc [] = acc+    loop !acc (x:xs) = loop (acc+x) xs+    {-# INLINE loop #-}

@@ -9,6 +9,8 @@ -- -- +{-# LANGUAGE FlexibleInstances #-}+ module Foundation.Class.Storable     ( Storable(..)     , StorableFixed(..)@@ -21,11 +23,14 @@  import Foreign.Ptr (castPtr) import qualified Foreign.Ptr+import qualified Foreign.Storable (peek, poke, sizeOf, alignment)+import           Foreign.C.Types (CChar, CUChar)  import Foundation.Internal.Base import Foundation.Internal.Types import Foundation.Internal.Proxy import Foundation.Primitive.Types+import Foundation.Primitive.Endianness import Foundation.Numerical  toProxy :: proxy ty -> Proxy ty@@ -57,6 +62,12 @@ pokeOff :: StorableFixed a => Ptr a -> Offset a -> a -> IO () pokeOff ptr off = poke (ptr `plusPtr` offsetAsSize off) +instance Storable CChar where+    peek (Ptr addr) = primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0)+instance Storable CUChar where+    peek (Ptr addr) = primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Char where     peek (Ptr addr) = primAddrRead addr (Offset 0)     poke (Ptr addr) = primAddrWrite addr (Offset 0)@@ -84,13 +95,40 @@ instance Storable Word16 where     peek (Ptr addr) = primAddrRead addr (Offset 0)     poke (Ptr addr) = primAddrWrite addr (Offset 0)+instance Storable (BE Word16) where+    peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE+instance Storable (LE Word16) where+    peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable Word32 where     peek (Ptr addr) = primAddrRead addr (Offset 0)     poke (Ptr addr) = primAddrWrite addr (Offset 0)+instance Storable (BE Word32) where+    peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE+instance Storable (LE Word32) where+    peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable Word64 where     peek (Ptr addr) = primAddrRead addr (Offset 0)     poke (Ptr addr) = primAddrWrite addr (Offset 0)+instance Storable (BE Word64) where+    peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE+instance Storable (LE Word64) where+    peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE+instance Storable (Ptr a) where+    peek = Foreign.Storable.peek+    poke = Foreign.Storable.poke +instance StorableFixed CChar where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed CUChar where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy instance StorableFixed Char where     size      = primSizeInBytes . toProxy     alignment = primSizeInBytes . toProxy@@ -118,9 +156,33 @@ instance StorableFixed Word16 where     size      = primSizeInBytes . toProxy     alignment = primSizeInBytes . toProxy+instance StorableFixed (BE Word16) where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed (LE Word16) where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy instance StorableFixed Word32 where     size      = primSizeInBytes . toProxy     alignment = primSizeInBytes . toProxy+instance StorableFixed (BE Word32) where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed (LE Word32) where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy instance StorableFixed Word64 where     size      = primSizeInBytes . toProxy     alignment = primSizeInBytes . toProxy+instance StorableFixed (BE Word64) where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed (LE Word64) where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed (Ptr a) where+    size      = Size . Foreign.Storable.sizeOf    . toUndefined+    alignment = Size . Foreign.Storable.alignment . toUndefined++toUndefined :: proxy a -> a+toUndefined _ = undefined

@@ -28,6 +28,7 @@     , Buildable(..)     , Builder(..)     , BuildingState(..)+    , Copy(..)     ) where  import           Foundation.Collection.Buildable@@ -40,3 +41,4 @@ import           Foundation.Collection.Collection import           Foundation.Collection.Sequential import           Foundation.Collection.Zippable+import           Foundation.Collection.Copy

@@ -7,7 +7,6 @@ -- -- An interface for collections that can be built incrementally. ---{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Collection.Buildable     ( Buildable(..)     , Builder(..)@@ -16,13 +15,12 @@  import           Foundation.Array.Unboxed import           Foundation.Array.Unboxed.Mutable+import qualified Foundation.Array.Boxed as BA+import qualified Foundation.String.UTF8 as S import           Foundation.Collection.Element import           Foundation.Internal.Base-import           Foundation.Internal.MonadTrans-import           Foundation.Internal.Types-import           Foundation.Numerical import           Foundation.Primitive.Monad-import           Foundation.Primitive.Types+import           Foundation.Boot.Builder  -- $setup -- >>> import Control.Monad.ST@@ -38,75 +36,46 @@ -- >>> runST $ build 32 (append 'a' >> append 'b' >> append 'c') :: UArray Char -- "abc" class Buildable col where-  {-# MINIMAL append, build #-}--  -- | Mutable collection type used for incrementally writing chunks.-  type Mutable col :: * -> *--  -- | Unit of the smallest step possible in an `append` operation.-  ---  -- A UTF-8 character can have a size between 1 and 4 bytes, so this-  -- should be defined as 1 byte for collections of `Char`.-  type Step col+    {-# MINIMAL append, build #-} -  append :: (PrimMonad prim) => Element col -> Builder col prim ()+    -- | Mutable collection type used for incrementally writing chunks.+    type Mutable col :: * -> * -  build :: (PrimMonad prim)-        => Int -- ^ Size of a chunk-        -> Builder col prim ()-        -> prim col+    -- | Unit of the smallest step possible in an `append` operation.+    --+    -- A UTF-8 character can have a size between 1 and 4 bytes, so this+    -- should be defined as 1 byte for collections of `Char`.+    type Step col -newtype Builder col st a = Builder-    { runBuilder :: State (Offset (Step col), BuildingState col (PrimState st)) st a }-    deriving (Functor, Applicative, Monad)+    append :: (PrimMonad prim) => Element col -> Builder col (Mutable col) (Step col) prim () --- | The in-progress state of a building operation.------ The previous buffers are in reverse order, and--- this contains the current buffer and the state of--- progress packing the elements inside.-data BuildingState col st = BuildingState-    { prevChunks     :: [col]-    , prevChunksSize :: !(Size (Step col))-    , curChunk       :: Mutable col st-    , chunkSize      :: !(Size (Step col))-    }+    build :: (PrimMonad prim)+          => Int -- ^ Size of a chunk+          -> Builder col (Mutable col) (Step col) prim ()+          -> prim col  instance PrimType ty => Buildable (UArray ty) where-  type Mutable (UArray ty) = MUArray ty-  type Step (UArray ty) = ty+    type Mutable (UArray ty) = MUArray ty+    type Step (UArray ty) = ty+    append = builderAppend+    {-# INLINE append #-}+    build = builderBuild+    {-# INLINE build #-} -  append v = Builder $ State $ \(i, st) ->-      if offsetAsSize i == chunkSize st-          then do-              cur      <- unsafeFreeze (curChunk st)-              newChunk <- new (chunkSize st)-              unsafeWrite newChunk 0 v-              return ((), (Offset 1, st { prevChunks     = cur : prevChunks st-                                        , prevChunksSize = chunkSize st + prevChunksSize st-                                        , curChunk       = newChunk-                                        }))-          else do-              let Offset i' = i-              unsafeWrite (curChunk st) i' v-              return ((), (i + Offset 1, st))-  {-# INLINE append #-}+instance Buildable (BA.Array ty) where+    type Mutable (BA.Array ty) = BA.MArray ty+    type Step (BA.Array ty) = ty -  build sizeChunksI ab-    | sizeChunksI <= 0 = build 64 ab-    | otherwise        = do-        first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (Size 0) first sizeChunks)-        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)-        -- Build final array-        let totalSize = prevChunksSize st + offsetAsSize i-        new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze-    where-      sizeChunks = Size sizeChunksI+    append = BA.builderAppend+    {-# INLINE append #-}+    build = BA.builderBuild+    {-# INLINE build #-} -      fillFromEnd _   []     mua = return mua-      fillFromEnd !end (x:xs) mua = do-          let sz = lengthSize x-          unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz-          fillFromEnd (end - sz) xs mua-  {-# INLINE build #-}+instance Buildable S.String where+    type Mutable S.String = S.MutableString+    type Step S.String = Word8++    append = S.builderAppend+    {-# INLINE append #-}+    build = S.builderBuild+    {-# INLINE build #-}

@@ -31,6 +31,8 @@ import           Foundation.Collection.Element import qualified Data.List import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Array.Boxed as BA+import qualified Foundation.String.UTF8 as S  -- | NonEmpty property for any Collection --@@ -63,7 +65,7 @@  -- | A set of methods for ordered colection class (IsList c, Item c ~ Element c) => Collection c where-    {-# MINIMAL null, length, (elem | notElem), minimum, maximum #-}+    {-# MINIMAL null, length, (elem | notElem), minimum, maximum, all, any #-}     -- | Check if a collection is empty     null :: c -> Bool     -- | Length of a collection (number of Element c)@@ -84,6 +86,12 @@     -- | Get the minimum element of a collection     minimum :: forall a . (Ord a, a ~ Element c) => NonEmpty c -> Element c +    -- | Determine is any elements of the collection satisfy the predicate+    any :: (Element c -> Bool) -> c -> Bool++    -- | Determine is all elements of the collection satisfy the predicate+    all :: (Element c -> Bool) -> c -> Bool+ instance Collection [a] where     null = Data.List.null     length = Data.List.length@@ -94,16 +102,41 @@     minimum = Data.List.minimum . getNonEmpty     maximum = Data.List.maximum . getNonEmpty +    any = Data.List.any+    all = Data.List.all+ 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 +instance Collection (BA.Array ty) where+    null = BA.null+    length = BA.length+    elem e = Data.List.elem e . toList+    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++instance Collection S.String where+    null = S.null+    length = S.length+    elem = S.elem+    minimum = Data.List.minimum . toList . getNonEmpty -- TODO faster implementation+    maximum = Data.List.maximum . toList . getNonEmpty -- TODO faster implementation+    all p = Data.List.all p . toList+    any p = Data.List.any p . toList+ instance Collection c => Collection (NonEmpty c) where     null _ = False     length = length . getNonEmpty     elem e = elem e . getNonEmpty     maximum = maximum . getNonEmpty     minimum = minimum . getNonEmpty+    all p = all p . getNonEmpty+    any p = any p . getNonEmpty

@@ -0,0 +1,18 @@+module Foundation.Collection.Copy+    ( Copy(..)+    ) where++import qualified Foundation.Array.Unboxed as UA+import qualified Foundation.Array.Boxed as BA+import qualified Foundation.String.UTF8 as S++class Copy a where+    copy :: a -> a+instance Copy [ty] where+    copy a = a+instance UA.PrimType ty => Copy (UA.UArray ty) where+    copy = UA.copy+instance Copy (BA.Array ty) where+    copy = BA.copy+instance Copy S.String where+    copy = S.copy

@@ -9,9 +9,14 @@     ( Element     ) where +import Foundation.Internal.Base import Foundation.Array.Unboxed (UArray)+import Foundation.Array.Boxed (Array)+import Foundation.String.UTF8 (String)  -- | Element type of a collection type family Element container type instance Element [a] = a type instance Element (UArray ty) = ty+type instance Element (Array ty) = ty+type instance Element String = Char

@@ -15,6 +15,7 @@ import           Foundation.Collection.Element import qualified Data.List import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Array.Boxed as BA  -- | Give the ability to fold a collection on itself class Foldable collection where@@ -54,3 +55,7 @@     foldl = UV.foldl     foldr = UV.foldr     foldl' = UV.foldl'+instance Foldable (BA.Array ty) where+    foldl = BA.foldl+    foldr = BA.foldr+    foldl' = BA.foldl'

@@ -15,6 +15,8 @@ import           Foundation.Collection.Element import qualified Data.List import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Array.Boxed as BA+import qualified Foundation.String.UTF8 as S  -- | Collection of elements that can indexed by int class IndexedCollection c where@@ -40,3 +42,19 @@             | i == len                       = Nothing             | predicate (UV.unsafeIndex c i) = Just i             | otherwise                      = Nothing++instance IndexedCollection (BA.Array ty) where+    (!) l n+        | n < 0 || n >= BA.length l = Nothing+        | otherwise                 = Just $ BA.index l n+    findIndex predicate c = loop 0+      where+        !len = BA.length c+        loop i+            | i == len  = Nothing+            | otherwise =+                if predicate (BA.unsafeIndex c i) then Just i else Nothing++instance IndexedCollection S.String where+    (!) = S.index+    findIndex = S.findIndex

@@ -5,7 +5,9 @@  import Foundation.Internal.Base import Foundation.Collection.Element+import qualified Foundation.String.UTF8 as S import qualified Foundation.Array.Unboxed as UV+import           Foundation.Array.Boxed (Array)  -- | A monomorphic functor that maps the inner values to values of the same type class InnerFunctor c where@@ -17,3 +19,8 @@  instance UV.PrimType ty => InnerFunctor (UV.UArray ty) where     imap = UV.map++instance InnerFunctor (Array ty)++instance InnerFunctor S.String where+    imap = S.charMap

@@ -1,5 +1,5 @@ -- |--- Module      : Foundation.Array.List+-- Module      : Foundation.Collection.List -- License     : BSD-style -- Maintainer  : Vincent Hanquez <vincent@snarc.org> -- Stability   : experimental

@@ -15,6 +15,7 @@  import qualified Foundation.Array.Unboxed.Mutable as MUV import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Array.Boxed as BA  -- | Collection of things that can be made mutable, modified and then freezed into an MutableFreezed collection class MutableCollection c where@@ -55,3 +56,19 @@     mutUnsafeRead = MUV.unsafeRead     mutWrite = MUV.write     mutRead = MUV.read++instance MutableCollection (BA.MArray ty) where+    type MutableFreezed (BA.MArray ty) = BA.Array ty+    type MutableKey (BA.MArray ty) = Int+    type MutableValue (BA.MArray ty) = ty++    thaw = BA.thaw+    freeze = BA.freeze+    unsafeThaw = BA.unsafeThaw+    unsafeFreeze = BA.unsafeFreeze++    mutNew n = BA.new (Size n)+    mutUnsafeWrite = BA.unsafeWrite+    mutUnsafeRead = BA.unsafeRead+    mutWrite = BA.write+    mutRead = BA.read

@@ -22,6 +22,8 @@ import qualified Foundation.Collection.List as ListExtra import qualified Data.List import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Array.Boxed as BA+import qualified Foundation.String.UTF8 as S  -- | A set of methods for ordered colection class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where@@ -207,3 +209,46 @@     find = UV.find     sortBy = UV.sortBy     singleton = fromList . (:[])++instance Sequential (BA.Array ty) where+    take = BA.take+    drop = BA.drop+    splitAt = BA.splitAt+    revTake = BA.revTake+    revDrop = BA.revDrop+    revSplitAt = BA.revSplitAt+    splitOn = BA.splitOn+    break = BA.break+    intersperse = BA.intersperse+    span = BA.span+    reverse = BA.reverse+    filter = BA.filter+    unsnoc = BA.unsnoc+    uncons = BA.uncons+    snoc = BA.snoc+    cons = BA.cons+    find = BA.find+    sortBy = BA.sortBy+    singleton = fromList . (:[])++instance Sequential S.String where+    take = S.take+    drop = S.drop+    splitAt = S.splitAt+    revTake = S.revTake+    revDrop = S.revDrop+    revSplitAt = S.revSplitAt+    splitOn = S.splitOn+    break = S.break+    breakElem = S.breakElem+    intersperse = S.intersperse+    span = S.span+    filter = S.filter+    reverse = S.reverse+    unsnoc = S.unsnoc+    uncons = S.uncons+    snoc = S.snoc+    cons = S.cons+    find = S.find+    sortBy = S.sortBy+    singleton = S.singleton

@@ -17,7 +17,8 @@     ) where  import qualified Foundation.Array.Unboxed as UV-import           Foundation.Collection.Buildable+import qualified Foundation.Array.Boxed as BA+import qualified Foundation.String.UTF8 as S import           Foundation.Collection.Element import           Foundation.Collection.Sequential import           Foundation.Internal.Base@@ -76,12 +77,26 @@ instance Zippable [c]  instance UV.PrimType ty => Zippable (UV.UArray ty) where-  zipWith f as bs = runST $ build 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') = append (f' a' b') >> go f' as' bs'+      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)+    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)+    where+      go _  []       _        = return ()+      go _  _        []       = return ()+      go f' (a':as') (b':bs') = S.builderAppend (f' a' b') >> go f' as' bs'+ class Zippable col => BoxedZippable col where    -- | 'zip' takes two collections and returns a collections of corresponding@@ -183,6 +198,8 @@               in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es, f `cons` fs, g `cons` gs)  instance BoxedZippable [a]+instance BoxedZippable (BA.Array ty)+  -- * Tuple helper functions 

@@ -0,0 +1,81 @@+module Foundation.Conduit+    ( Conduit+    , ResourceT+    , ZipSink (..)+    , await+    , yield+    , yieldOr+    , leftover+    , runConduit+    , runConduitPure+    , runConduitRes+    , fuse+    , (.|)+    , sourceFile+    , sourceHandle+    , sinkFile+    , sinkHandle+    , sinkList+    , bracketConduit+    ) where++import Foundation.Conduit.Internal+import Foundation.Collection+import Foundation.IO+import Foundation.IO.File+import Foundation.Internal.Base+import Foundation.Monad.Base+import Foundation.Array+import Foundation+import System.IO (Handle)+++infixr 2 .|+-- | Operator version of 'fuse'.+(.|) :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r+(.|) = fuse+{-# INLINE (.|) #-}++sourceFile :: MonadResource m => FilePath -> Conduit i (UArray Word8) m ()+sourceFile fp = bracketConduit+    (openFile fp ReadMode)+    closeFile+    sourceHandle++sourceHandle :: MonadIO m+             => Handle+             -> Conduit i (UArray Word8) m ()+sourceHandle h =+    loop+  where+    defaultChunkSize :: Int+    defaultChunkSize = (32 :: Int) * 1000 - 16+    loop = do+        arr <- liftIO (hGet h defaultChunkSize)+        if null arr+            then return ()+            else yield arr >> loop++sinkFile :: MonadResource m => FilePath -> Conduit (UArray Word8) i m ()+sinkFile fp = bracketConduit+    (openFile fp WriteMode)+    closeFile+    sinkHandle++sinkHandle :: MonadIO m+           => Handle+           -> Conduit (UArray Word8) o m ()+sinkHandle h =+    loop+  where+    loop = await >>= maybe+        (return ())+        (\arr -> liftIO (hPut h arr) >> loop)++sinkList :: Monad m => Conduit i o m [i]+sinkList =+    loop id+  where+    loop front = await >>= maybe+        (return (front []))+        (\x -> loop (front . (x:)))

@@ -0,0 +1,390 @@+-- Module      : Foundation.Conduit.Internal+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--+-- Taken from the conduit package almost verbatim, and+-- Copyright (c) 2012 Michael Snoyman+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+module Foundation.Conduit.Internal+    ( Pipe(..)+    , Conduit(..)+    , ZipSink(..)+    , ResourceT(..)+    , MonadResource(..)+    , runResourceT+    , await+    , yield+    , yieldOr+    , leftover+    , runConduit+    , runConduitRes+    , runConduitPure+    , fuse+    , bracketConduit+    ) where++import Foundation.Internal.Base hiding (throw)+import Foundation.Monad+import Foundation.Numerical+import Foundation.Primitive.Monad+import Control.Monad ((>=>), liftM, void, mapM_, join)+import Control.Exception (SomeException, mask_)+import Data.IORef (atomicModifyIORef)++-- | A pipe producing and consuming values+--+-- A basic intuition is that every @Pipe@ produces a stream of /output/ values+-- and eventually indicates that this stream is terminated by sending a+-- /result/. On the receiving end of a @Pipe@, these become the /input/ and /upstream/+-- parameters.+data Pipe leftOver input output upstream monad result =+      -- | Provide new output to be sent downstream. This constructor has three+      -- fields: the next @Pipe@ to be used, a finalization function, and the+      -- output value.+      Yield (Pipe leftOver input output upstream monad result) (monad ()) output+      -- | Request more input from upstream. The first field takes a new input+      -- value and provides a new @Pipe@. The second takes an upstream result+      -- value, which indicates that upstream is producing no more results.+    | Await (input -> Pipe leftOver input output upstream monad result)+                (upstream -> Pipe leftOver input output upstream monad result)+      -- | Processing with this @Pipe@ is complete, providing the final result.+    | Done result+      -- | Require running of a monadic action to get the next @Pipe@.+    | PipeM (monad (Pipe leftOver input output upstream monad result))+      -- | Return leftover input, which should be provided to future operations.+    | Leftover (Pipe leftOver input output upstream monad result) leftOver++instance Applicative m => Functor (Pipe l i o u m) where+    fmap = (<$>)+    {-# INLINE fmap #-}++instance Applicative m => Applicative (Pipe l i o u m) where+    pure = Done+    {-# INLINE pure #-}++    Yield p c o  <*> fa = Yield (p <*> fa) c o+    Await p c    <*> fa = Await (\i -> p i <*> fa) (\o -> c o <*> fa)+    Done r       <*> fa = r <$> fa+    PipeM mp     <*> fa = PipeM ((<*> fa) <$> mp)+    Leftover p i <*> fa = Leftover (p <*> fa) i+    {-# INLINE (<*>) #-}++instance (Functor m, Monad m) => Monad (Pipe l i o u m) where+    return = Done+    {-# INLINE return #-}++    Yield p c o  >>= fp = Yield    (p >>= fp)            c          o+    Await p c    >>= fp = Await    (p >=> fp)            (c >=> fp)+    Done x       >>= fp = fp x+    PipeM mp     >>= fp = PipeM    ((>>= fp) <$> mp)+    Leftover p i >>= fp = Leftover (p >>= fp)            i++-- | A component of a conduit pipeline, which takes a stream of+-- @input@, produces a stream of @output@, performs actions in the+-- underlying @monad@, and produces a value of @result@ when no more+-- output data is available.+newtype Conduit input output monad result = Conduit+    { unConduit :: forall a .  (result -> Pipe input input output () monad a) -> Pipe input input output () monad a+    }++instance Functor (Conduit i o m) where+    fmap f (Conduit c) = Conduit $ \resPipe -> c (resPipe . f)++instance Applicative (Conduit i o m) where+    pure x = Conduit ($ x)+    {-# INLINE pure #-}++    fab <*> fa = fab >>= \ab -> fa >>= \a -> pure (ab a)+    {-# INLINE (<*>) #-}++instance Monad (Conduit i o m) where+    return = pure+    Conduit f >>= g = Conduit $ \h -> f $ \a -> unConduit (g a) h++instance MonadTrans (Conduit i o) where+    lift m = Conduit $ \rest -> PipeM $ liftM rest m++instance MonadIO m => MonadIO (Conduit i o m) where+    liftIO = lift . liftIO++instance MonadFailure m => MonadFailure (Conduit i o m) where+    type Failure (Conduit i o m) = Failure m+    mFail = lift . mFail++instance MonadThrow m => MonadThrow (Conduit i o m) where+    throw = lift . throw++instance MonadCatch m => MonadCatch (Conduit i o m) where+    catch (Conduit c0) onExc = Conduit $ \rest -> let+        go (PipeM m) =+            PipeM $ catch (liftM go m) (return . flip unConduit rest . onExc)+        go (Done r) = rest r+        go (Await p c) = Await (go . p) (go . c)+        go (Yield p m o) = Yield (go p) m o+        go (Leftover p i) = Leftover (go p) i++        in go (c0 Done)++-- | Await for a value from upstream.+await :: Conduit i o m (Maybe i)+await = Conduit $ \f -> Await (f . Just) (const (f Nothing))+{-# NOINLINE[1] await  #-}++await' :: Conduit i o m r+       -> (i -> Conduit i o m r)+       -> Conduit i o m r+await' f g = Conduit $ \rest -> Await+    (\i -> unConduit (g i) rest)+    (const $ unConduit f rest)+{-# INLINE await' #-}+{-# RULES "conduit: await >>= maybe" [2] forall x y. await >>= maybe x y = await' x y #-}++-- | Send a value downstream.+yield :: Monad m => o -> Conduit i o m ()+yield o = Conduit $ \f -> Yield (f ()) (return ()) o++-- | Same as 'yield', but additionally takes a finalizer to be run if+-- the downstream component terminates.+yieldOr :: o+        -> m () -- ^ finalizer+        -> Conduit i o m ()+yieldOr o m = Conduit $ \f -> Yield (f ()) m o++-- | Provide leftover input to be consumed by the next component in+-- the current monadic binding.+leftover :: i -> Conduit i o m ()+leftover i = Conduit $ \f -> Leftover (f ()) i++-- | Run a conduit pipeline to completion.+runConduit :: Monad m => Conduit () () m r -> m r+runConduit (Conduit f) = runPipe (f Done)++-- | Run a pure conduit pipeline to completion.+runConduitPure :: Conduit () () Identity r -> r+runConduitPure = runIdentity . runConduit++-- | Run a conduit pipeline in a 'ResourceT' context for acquiring resources.+runConduitRes :: (MonadBracket m, MonadIO m) => Conduit () () (ResourceT m) r -> m r+runConduitRes = runResourceT . runConduit++bracketConduit :: MonadResource m+               => IO a+               -> (a -> IO b)+               -> (a -> Conduit i o m r)+               -> Conduit i o m r+bracketConduit acquire cleanup inner = do+    (resource, release) <- allocate acquire cleanup+    result <- inner resource+    release+    return result++-- | Internal: run a @Pipe@+runPipe :: Monad m => Pipe () () () () m r -> m r+runPipe =+    go+  where+    go (Yield p _ ()) = go p+    go (Await _ p) = go (p ())+    go (Done r) = return r+    go (PipeM mp) = mp >>= go+    go (Leftover p ()) = go p++-- | Send the output of the first Conduit component to the second+-- Conduit component.+fuse :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r+fuse (Conduit left0) (Conduit right0) = Conduit $ \rest ->+    let goRight final left right =+            case right of+                Yield p c o       -> Yield (recurse p) (c >> final) o+                Await rp rc       -> goLeft rp rc final left+                Done r2           -> PipeM (final >> return (rest r2))+                PipeM mp          -> PipeM (liftM recurse mp)+                Leftover right' i -> goRight final (Yield left final i) right'+          where+            recurse = goRight final left++        goLeft rp rc final left =+            case left of+                Yield left' final' o -> goRight final' left' (rp o)+                Await left' lc       -> Await (recurse . left') (recurse . lc)+                Done r1              -> goRight (return ()) (Done r1) (rc r1)+                PipeM mp             -> PipeM (liftM recurse mp)+                Leftover left' i     -> Leftover (recurse left') i+          where+            recurse = goLeft rp rc final+     in goRight (return ()) (left0 Done) (right0 Done)++{- FIXME for later, if we add resourcet+-- | Safely acquire a resource and register a cleanup action for it,+-- in the context of a 'Conduit'.+bracketConduit :: MonadResource m+               => IO a -- ^ acquire+               -> (a -> IO ()) -- ^ cleanup+               -> (a -> Conduit i o m r)+               -> Conduit i o m r+bracketConduit alloc cleanup inner = Conduit $ \rest -> PipeM $ do+    (key, val) <- allocate alloc cleanup+    return $ unConduit (addCleanup (const $ release key) (inside seed)) rest++addCleanup :: Monad m+           => (Bool -> m ())+           -> Conduit i o m r+           -> Conduit i o m r+addCleanup cleanup (Conduit c0) = Conduit $ \rest -> let+    go (Done r) = PipeM (cleanup True >> return (rest r))+    go (Yield src close x) = Yield+        (go src)+        (cleanup False >> close)+        x+    go (PipeM msrc) = PipeM (liftM (go) msrc)+    go (Await p c) = Await+        (go . p)+        (go . c)+    go (Leftover p i) = Leftover (go p) i+    in go (c0 Done)+-}++newtype ZipSink i m r = ZipSink { getZipSink :: Conduit i () m r }++instance Monad m => Functor (ZipSink i m) where+    fmap f (ZipSink x) = ZipSink (liftM f x)+instance Monad m => Applicative (ZipSink i m) where+    pure  = ZipSink . return+    ZipSink (Conduit f0) <*> ZipSink (Conduit x0) =+      ZipSink $ Conduit $ \rest -> let+        go (Leftover _ i) _ = absurd i+        go _ (Leftover _ i) = absurd i+        go (Yield f _ ()) x = go f x+        go f (Yield x _ ()) = go f x+        go (PipeM mf) x = PipeM (liftM (`go` x) mf)+        go f (PipeM mx) = PipeM (liftM (go f) mx)+        go (Done f) (Done x) = rest (f x)+        go (Await pf cf) (Await px cx) = Await+            (\i -> go (pf i) (px i))+            (\() -> go (cf ()) (cx ()))+        go (Await pf cf) x@Done{} = Await+            (\i -> go (pf i) x)+            (\() -> go (cf ()) x)+        go f@Done{} (Await px cx) = Await+            (\i -> go f (px i))+            (\() -> go f (cx ()))++      in go (injectLeftovers (f0 Done)) (injectLeftovers (x0 Done))++data Void++absurd :: Void -> a+absurd _ = error "Foundation.Conduit.Internal.absurd"++injectLeftovers :: Monad m => Pipe i i o u m r -> Pipe l i o u m r+injectLeftovers =+    go []+  where+    go ls (Yield p c o) = Yield (go ls p) c o+    go (l:ls) (Await p _) = go ls $ p l+    go [] (Await p c) = Await (go [] . p) (go [] . c)+    go _ (Done r) = Done r+    go ls (PipeM mp) = PipeM (liftM (go ls) mp)+    go ls (Leftover p l) = go (l:ls) p++---------------------+-- ResourceT+---------------------+newtype ResourceT m a = ResourceT { unResourceT :: PrimVar IO ReleaseMap -> m a }+instance Functor m => Functor (ResourceT m) where+    fmap f (ResourceT m) = ResourceT $ \r -> fmap f (m r)+instance Applicative m => Applicative (ResourceT m) where+    pure = ResourceT . const . pure+    ResourceT mf <*> ResourceT ma = ResourceT $ \r ->+        mf r <*> ma r+instance Monad m => Monad (ResourceT m) where+#if !MIN_VERSION_base(4,8,0)+    return = ResourceT . const . return+#endif+    ResourceT ma >>= f = ResourceT $ \r -> do+        a <- ma r+        let ResourceT f' = f a+        f' r+instance MonadTrans ResourceT where+    lift = ResourceT . const+instance MonadIO m => MonadIO (ResourceT m) where+    liftIO = lift . liftIO+instance MonadThrow m => MonadThrow (ResourceT m) where+    throw = lift . throw+instance MonadCatch m => MonadCatch (ResourceT m) where+    catch (ResourceT f) g = ResourceT $ \env -> f env `catch` \e -> unResourceT (g e) env+instance MonadBracket m => MonadBracket (ResourceT m) where+    generalBracket acquire onSuccess onExc inner = ResourceT $ \env -> generalBracket+        (unResourceT acquire env)+        (\x y -> unResourceT (onSuccess x y) env)+        (\x y -> unResourceT (onExc x y) env)+        (\x -> unResourceT (inner x) env)++data ReleaseMap =+    ReleaseMap !NextKey !RefCount ![(Word, (ReleaseType -> IO ()))] -- FIXME use a proper Map?+  | ReleaseMapClosed++data ReleaseType = ReleaseEarly+                 | ReleaseNormal+                 | ReleaseException++type RefCount = Word+type NextKey = Word++runResourceT :: (MonadBracket m, MonadIO m) => ResourceT m a -> m a+runResourceT (ResourceT inner) = generalBracket+    (liftIO $ primVarNew $ ReleaseMap maxBound (minBound + 1) [])+    (\state _res -> liftIO $ cleanup state ReleaseNormal)+    (\state _exc -> liftIO $ cleanup state ReleaseException)+    inner+  where+    cleanup istate rtype = do+        mm <- atomicModifyIORef istate $ \rm ->+            case rm of+                ReleaseMap nk rf m ->+                    let rf' = rf - 1+                    in if rf' == minBound+                            then (ReleaseMapClosed, Just m)+                            else (ReleaseMap nk rf' m, Nothing)+                ReleaseMapClosed -> error "runResourceT: cleanup on ReleaseMapClosed"+        case mm of+            Just m -> mapM_ (\(_, x) -> ignoreExceptions (x rtype)) m+            Nothing -> return ()+      where+        ignoreExceptions io = void io `catch` (\(_ :: SomeException) -> return ())++allocate :: (MonadResource m, MonadIO n) => IO a -> (a -> IO b) -> m (a, n ())+allocate acquire release = liftResourceT $ ResourceT $ \istate -> liftIO $ mask_ $ do+    a <- acquire+    key <- atomicModifyIORef istate $ \rm ->+        case rm of+            ReleaseMap key rf m ->+                ( ReleaseMap (key - 1) rf ((key, const $ void $ release a) : m)+                , key+                )+            ReleaseMapClosed -> error "allocate: ReleaseMapClosed"+    let release' = join $ atomicModifyIORef istate $ \rm ->+            case rm of+                ReleaseMap nextKey rf m ->+                    let loop front [] = (ReleaseMap nextKey rf (front []), return ())+                        loop front ((key', action):rest)+                            | key == key' =+                                ( ReleaseMap nextKey rf (front rest)+                                , action ReleaseEarly+                                )+                            | otherwise = loop (front . ((key', action):)) rest+                     in loop id m+                ReleaseMapClosed -> error "allocate: ReleaseMapClosed (2)"+    return (a, liftIO release')++class MonadIO m => MonadResource m where+    liftResourceT :: ResourceT IO a -> m a+instance MonadIO m => MonadResource (ResourceT m) where+    liftResourceT (ResourceT f) = ResourceT (liftIO . f)+instance MonadResource m => MonadResource (Conduit i o m) where+    liftResourceT = lift . liftResourceT

@@ -50,12 +50,16 @@ xor64 !a !b = a `xor` Prelude.fromIntegral b {-# INLINE xor64 #-} +-- | FNV1 32 bit state newtype FNV1_32 = FNV1_32 Word +-- | FNV1 64 bit state newtype FNV1_64 = FNV1_64 Word64 +-- | FNV1a 32 bit state newtype FNV1a_32 = FNV1a_32 Word +-- | FNV1a 64 bit state newtype FNV1a_64 = FNV1a_64 Word64  fnv1_32_Mix8 :: Word8 -> FNV1_32 -> FNV1_32

@@ -17,6 +17,7 @@     , Sip2_4     ) where +import           Data.Bits import           Foundation.Internal.Base import           Foundation.Internal.Types import           Foundation.Primitive.Types@@ -25,7 +26,6 @@ import           Foundation.Array import           Foundation.Numerical import           Foundation.Bits-import           Data.Bits import qualified Prelude import           GHC.ST import           GHC.Prim

@@ -17,6 +17,7 @@     , Foundation.IO.File.closeFile     , Foundation.IO.File.withFile     , Foundation.IO.File.hGet+    , Foundation.IO.File.hPut     , Foundation.IO.File.readFile     , Foundation.IO.File.foldTextFile     ) where

@@ -6,13 +6,15 @@ -- Portability : portable -- module Foundation.IO.File-    ( openFile+    ( FilePath+    , openFile     , closeFile     , IOMode(..)     , withFile     , hGet     , hGetNonBlocking     , hGetSome+    , hPut     , readFile     , foldTextFile     ) where@@ -26,6 +28,7 @@ import           Foundation.Internal.Base import           Foundation.String import           Foundation.Array+import           Foundation.Array.Internal import           Foundation.Numerical import qualified Foundation.Array.Unboxed.Mutable as V import qualified Foundation.Array.Unboxed as V@@ -57,7 +60,7 @@ hGet :: Handle -> Int -> IO (UArray Word8) hGet h size     | size < 0   = invalidBufferSize "hGet" h size-    | otherwise  = V.createFromIO size $ \p -> S.hGetBuf h p size+    | otherwise  = V.createFromIO (Size size) $ \p -> (Size <$> S.hGetBuf h p size)  -- | hGetNonBlocking is similar to 'hGet', except that it will never block -- waiting for data to become available, instead it returns only whatever data@@ -68,7 +71,7 @@ hGetNonBlocking :: Handle -> Int -> IO (UArray Word8) hGetNonBlocking h size     | size < 0  = invalidBufferSize "hGetNonBlocking" h size-    | otherwise = V.createFromIO size $ \p -> S.hGetBufNonBlocking h p size+    | otherwise = V.createFromIO (Size size) $ \p -> (Size <$> S.hGetBufNonBlocking h p size)  -- | Like 'hGet', except that a shorter array may be returned -- if there are not enough bytes immediately available to satisfy the@@ -78,7 +81,10 @@ hGetSome :: Handle -> Int -> IO (UArray Word8) hGetSome h size     | size < 0  = invalidBufferSize "hGetSome" h size-    | otherwise = V.createFromIO size $ \p -> S.hGetBufSome h p size+    | otherwise = V.createFromIO (Size size) $ \p -> (Size <$> S.hGetBufSome h p size)++hPut :: Handle -> (UArray Word8) -> IO ()+hPut h arr = withPtr arr $ \ptr -> S.hPutBuf h ptr (length arr)  invalidBufferSize :: [Char] -> Handle -> Int -> IO a invalidBufferSize functionName handle size =

@@ -0,0 +1,82 @@+-- |+-- Module      : Foundation.Internal.ByteSwap+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : experimental+-- Portability : portable+--++{-# LANGUAGE CPP #-}++module Foundation.Internal.ByteSwap+    ( byteSwap16+    , byteSwap32+    , byteSwap64+    , ByteSwap+    , byteSwap+    ) where++import Foundation.Internal.Base (Word16, Word32, Word64)++#if MIN_VERSION_base(4,7,0)++import Data.Word (byteSwap16, byteSwap32, byteSwap64)++#else++import Foundation.Internal.Base (fromInteger)++import Data.Bits ((.|.), (.&.), unsafeShiftL, unsafeShiftR)++import Data.Word (Word16, Word32, Word64)++-- | compatibility implementation (i.e. may be slow)+--+-- Swap the bytes position (inverting order) as would be done in GHC >= 7.8+byteSwap16 :: Word16 -> Word16+byteSwap16 w = w1 .|. w2+  where+    w1,w2 :: Word16+    w1 = (w `unsafeShiftL` 8) .&. 0xFF00+    w2 = (w `unsafeShiftR` 8) .&. 0x00FF++-- | compatibility implementation (i.e. may be slow)+--+-- Swap the bytes position (inverting order) as would be done in GHC >= 7.8+byteSwap32 :: Word32 -> Word32+byteSwap32 w = w1 .|. w2 .|. w3 .|. w4+  where+    w1,w2,w3,w4 :: Word32+    w1 = (w `unsafeShiftL` 24) .&. 0xFF000000+    w2 = (w `unsafeShiftR` 24) .&. 0x000000FF+    w3 = (w `unsafeShiftL` 8)  .&. 0x00FF0000+    w4 = (w `unsafeShiftR` 8)  .&. 0x0000FF00++-- | compatibility implementation (i.e. may be slow)+--+-- Swap the bytes position (inverting order) as would be done in GHC >= 7.8+byteSwap64 :: Word64 -> Word64+byteSwap64 w = w1 .|. w2 .|. w3 .|. w4 .|. w5 .|. w6 .|. w7 .|. w8+  where+    w1,w2,w3,w4,w5,w6,w7,w8 :: Word64+    w1 = (w `unsafeShiftL` 56) .&. 0xFF00000000000000+    w2 = (w `unsafeShiftR` 56) .&. 0x00000000000000FF+    w3 = (w `unsafeShiftL` 40) .&. 0x00FF000000000000+    w4 = (w `unsafeShiftR` 40) .&. 0x000000000000FF00+    w5 = (w `unsafeShiftL` 24) .&. 0x0000FF0000000000+    w6 = (w `unsafeShiftR` 24) .&. 0x0000000000FF0000+    w7 = (w `unsafeShiftL`  8) .&. 0x000000FF00000000+    w8 = (w `unsafeShiftR`  8) .&. 0x00000000FF000000+#endif++-- | Class of types that can be byte-swapped.+--+-- e.g. Word16, Word32, Word64+class ByteSwap a where+    byteSwap :: a -> a+instance ByteSwap Word16 where+    byteSwap = byteSwap16+instance ByteSwap Word32 where+    byteSwap = byteSwap32+instance ByteSwap Word64 where+    byteSwap = byteSwap64

@@ -6,15 +6,50 @@ -- Portability : portable -- -- Global configuration environment++{-# LANGUAGE CPP #-}+ module Foundation.Internal.Environment     ( unsafeUArrayUnpinnedMaxSize     ) where  import           Foundation.Internal.Base import           Foundation.Internal.Types-import           System.Environment import           System.IO.Unsafe          (unsafePerformIO)-import           Text.Read++#if MIN_VERSION_base(4,6,0)+import           System.Environment (lookupEnv)+import           Text.Read (readMaybe)+#else+import           System.Environment (getEnvironment)+import           Data.List (lookup)+import           Text.Read (Read, minPrec, readPrec, lift)+import           Text.ParserCombinators.ReadP as P+import           Text.ParserCombinators.ReadPrec (readPrec_to_S)+#endif++#if !MIN_VERSION_base(4,6,0)+lookupEnv :: [Char] -> IO (Maybe [Char])+lookupEnv envName = lookup envName <$> getEnvironment++readEither :: Read a => [Char] -> Either [Char] a+readEither s =+  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of+    [x] -> Right x+    []  -> Left "Prelude.read: no parse"+    _   -> Left "Prelude.read: ambiguous parse"+ where+  read' =+    do x <- readPrec+       lift P.skipSpaces+       return x++readMaybe :: Read a => [Char] -> Maybe a+readMaybe s = case readEither s of+    Left _  -> Nothing+    Right a -> Just a++#endif  -- | Defines the maximum size in bytes of unpinned arrays. --

@@ -0,0 +1,38 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}+module Foundation.Internal.Error+    ( error+    ) where++import           GHC.Prim+import           Foundation.String.UTF8+import           Foundation.Internal.CallStack++#if MIN_VERSION_base(4,9,0)++import           GHC.Types (RuntimeRep)+import           GHC.Exception (errorCallWithCallStackException)++-- | stop execution and displays an error message+error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a+error s = raise# (errorCallWithCallStackException (sToList s) ?callstack)++#elif MIN_VERSION_base(4,7,0)++import           GHC.Exception (errorCallException)++error :: String -> a+error s = raise# (errorCallException (sToList s))++#else++import           GHC.Types+import           GHC.Exception++error :: String -> a+error s = throw (ErrorCall (sToList s))++#endif

@@ -104,6 +104,14 @@     negate = Prelude.negate instance HasNegation CInt where     negate = Prelude.negate+instance HasNegation Float where+    negate = Prelude.negate+instance HasNegation Double where+    negate = Prelude.negate+instance HasNegation CFloat where+    negate = Prelude.negate+instance HasNegation CDouble where+    negate = Prelude.negate  instance Fractional Rational where     fromRational a = Prelude.fromRational a

@@ -7,19 +7,33 @@ import           Foundation.Numerical import qualified Prelude +-- | Method to support basic trigonometric functions class Trigonometry a where+    -- | the famous pi value     pi    :: a+    -- | sine     sin   :: a -> a+    -- | cosine     cos   :: a -> a+    -- | tan     tan   :: a -> a+    -- | sine-1     asin  :: a -> a+    -- | cosine-1     acos  :: a -> a+    -- | tangent-1     atan  :: a -> a+    -- | hyperbolic sine     sinh  :: a -> a+    -- | hyperbolic cosine     cosh  :: a -> a+    -- | hyperbolic tangent     tanh  :: a -> a+    -- | hyperbolic sine-1     asinh :: a -> a+    -- | hyperbolic cosine-1     acosh :: a -> a+    -- | hyperbolic tangent-1     atanh :: a -> a  instance Trigonometry FP32 where

@@ -1,11 +1,52 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-} module Foundation.Monad     ( MonadIO(..)     , MonadFailure(..)     , MonadThrow(..)     , MonadCatch(..)+    , MonadBracket(..)     , MonadTrans(..)+    , Identity(..)     ) where  import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity++#else++import Control.Monad.Fix+import Control.Monad.Zip+import Foundation.Internal.Base+import GHC.Generics (Generic1)++-- | Identity functor and monad. (a non-strict monad)+--+-- @since 4.8.0.0+newtype Identity a = Identity { runIdentity :: a }+    deriving (Eq, Ord, Data, Generic, Generic1, Typeable)++instance Functor Identity where+    fmap f (Identity x) = Identity (f x)++instance Applicative Identity where+    pure     = Identity+    Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+    return   = Identity+    m >>= k  = k (runIdentity m)++instance MonadFix Identity where+    mfix f   = Identity (fix (runIdentity . f))++instance MonadZip Identity where+    mzipWith f (Identity x) (Identity y) = Identity (f x y)+    munzip (Identity (x, y)) = (Identity x, Identity y)++#endif

@@ -1,12 +1,13 @@-+{-# LANGUAGE ScopedTypeVariables #-} module Foundation.Monad.Exception     ( MonadFailure(..)     , MonadThrow(..)     , MonadCatch(..)+    , MonadBracket(..)     ) where  import           Foundation.Internal.Base-import qualified Control.Exception (throwIO, catch)+import qualified Control.Exception as E  -- | Monad that can represent failure --@@ -29,6 +30,23 @@ class MonadThrow m => MonadCatch m where     catch :: Exception e => m a -> (e -> m a) -> m a +-- | Monad that can ensure cleanup actions are performed even in the+-- case of exceptions, both synchronous and asynchronous. This usually+-- excludes continuation-based monads.+class MonadCatch m => MonadBracket m where+    -- | A generalized version of the standard bracket function which+    -- allows distinguishing different exit cases.+    generalBracket+        :: m a+        -- ^ acquire some resource+        -> (a -> b -> m ignored1)+        -- ^ cleanup, no exception thrown+        -> (a -> E.SomeException -> m ignored2)+        -- ^ cleanup, some exception thrown. The exception will be rethrown+        -> (a -> m b)+        -- ^ inner action to perform with the resource+        -> m b+ instance MonadFailure Maybe where     type Failure Maybe = ()     mFail _ = Nothing@@ -37,6 +55,21 @@     mFail a = Left a  instance MonadThrow IO where-    throw = Control.Exception.throwIO+    throw = E.throwIO instance MonadCatch IO where-    catch = Control.Exception.catch+    catch = E.catch+instance MonadBracket IO where+    generalBracket acquire onSuccess onException inner = E.mask $ \restore -> do+        x <- acquire+        res1 <- E.try $ restore $ inner x+        case res1 of+            Left (e1 :: E.SomeException) -> do+                -- explicitly ignore exceptions from the cleanup+                -- action so we keep the original exception+                E.uninterruptibleMask_ $ fmap (const ()) (onException x e1) `E.catch`+                    (\(_ :: E.SomeException) -> return ())+                E.throwIO e1+            Right y -> do+                -- Allow exceptions from the onSuccess function to propagate+                _ <- onSuccess x y+                return y

@@ -1,5 +1,11 @@+-- |+-- The identity monad transformer.+--+-- This is useful for functions parameterized by a monad transformer.+-- module Foundation.Monad.Identity     ( IdentityT+    , runIdentityT     ) where  import Foundation.Internal.Base hiding (throw)@@ -7,6 +13,7 @@ import Foundation.Monad.Exception import Foundation.Monad.Transformer +-- | Identity Transformer newtype IdentityT m a = IdentityT { runIdentityT :: m a }  instance Functor m => Functor (IdentityT m) where

@@ -1,5 +1,11 @@+-- |+-- The Reader monad transformer.+--+-- This is useful to keep a non-modifiable value+-- in a context module Foundation.Monad.Reader     ( ReaderT+    , runReaderT     ) where  import Foundation.Internal.Base (($), (.), const)@@ -37,7 +43,7 @@     mFail e = ReaderT $ \_ -> mFail e  instance MonadThrow m => MonadThrow (ReaderT r m) where-    throw e = ReaderT $ \_ -> throw e +    throw e = ReaderT $ \_ -> throw e  instance MonadCatch m => MonadCatch (ReaderT r m) where     catch (ReaderT m) c = ReaderT $ \r -> m r `catch` (\e -> runReaderT (c e) r)

@@ -1,6 +1,7 @@ {-# LANGUAGE TupleSections #-} module Foundation.Monad.State     ( StateT+    , runStateT     ) where  import Foundation.Internal.Base (($), (.))@@ -41,7 +42,7 @@     mFail e = StateT $ \s -> ((,s) `fmap` mFail e)  instance (Functor m, MonadThrow m) => MonadThrow (StateT s m) where-    throw e = StateT $ \_ -> throw e +    throw e = StateT $ \_ -> throw e  instance (Functor m, MonadCatch m) => MonadCatch (StateT s m) where     catch (StateT m) c = StateT $ \s1 -> m s1 `catch` (\e -> runStateT (c e) s1)

@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Foundation.Network.IPv4+    ( IPv4+    , fromString, toString+    , fromTuple, toTuple+    , ipv4Parser+    ) where++import Prelude (fromIntegral,read)++import Foundation.Class.Storable+import Foundation.Hashing.Hashable+import Foundation.Internal.Base+import Foundation.Internal.Proxy+import Foundation.String (String)+import Foundation.Primitive+import Foundation.Bits+import Foundation.Parser+import Foundation.Collection++-- | IPv4 data type+newtype IPv4 = IPv4 Word32+  deriving (Eq, Ord, Typeable, Hashable)+instance Show IPv4 where+    show = toLString+instance IsString IPv4 where+    fromString = fromLString+instance Storable IPv4 where+    peek ptr = IPv4 . fromBE <$> peek (castPtr ptr)+    poke ptr (IPv4 w) = poke (castPtr ptr) (toBE w)+instance StorableFixed IPv4 where+    size      _ = size      (Proxy :: Proxy Word32)+    alignment _ = alignment (Proxy :: Proxy Word32)++toString :: IPv4 -> String+toString = fromList . toLString++fromLString :: [Char] -> IPv4+fromLString = parseOnly ipv4Parser++toLString :: IPv4 -> [Char]+toLString ipv4 =+    let (i1, i2, i3, i4) = toTuple ipv4+     in show i1 <> "." <> show i2 <> "." <> show i3 <> "." <> show i4++fromTuple :: (Word8, Word8, Word8, Word8) -> IPv4+fromTuple (i1, i2, i3, i4) =+     IPv4 $     (w1 .<<. 24) .&. 0xFF000000+            .|. (w2 .<<. 16) .&. 0x00FF0000+            .|. (w3 .<<.  8) .&. 0x0000FF00+            .|.  w4          .&. 0x000000FF+  where+    f = fromIntegral+    w1, w2, w3, w4 :: Word32+    w1 = f i1+    w2 = f i2+    w3 = f i3+    w4 = f i4++toTuple :: IPv4 -> (Word8, Word8, Word8, Word8)+toTuple (IPv4 w) =+    (f w1, f w2, f w3, f w4)+  where+    f = fromIntegral+    w1, w2, w3, w4 :: Word32+    w1 = w .>>. 24 .&. 0x000000FF+    w2 = w .>>. 16 .&. 0x000000FF+    w3 = w .>>.  8 .&. 0x000000FF+    w4 = w         .&. 0x000000FF++-- | Parse a IPv4 address+ipv4Parser :: (Sequential input, Element input ~ Char) => Parser input IPv4+ipv4Parser = do+    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+    isAsciiDecimal = flip elem ['0'..'9']

@@ -0,0 +1,256 @@+-- |+-- Module      : Foundation.Network.IPv6+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- Stability   : experimental+-- Portability : portable+--+-- IPv6 data type+--+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Foundation.Network.IPv6+    ( IPv6+    , fromString, toString+    , fromTuple, toTuple+      -- * parsers+    , ipv6Parser+    , ipv6ParserPreferred+    , ipv6ParserCompressed+    , ipv6ParserIpv4Embedded+    ) where++import Prelude (fromIntegral, replicate, read)+import qualified Text.Printf as Base+import Data.Char (isHexDigit, isDigit)+import Numeric (readHex)+import Control.Monad (when)++import Foundation.Class.Storable+import Foundation.Hashing.Hashable+import Foundation.Numerical.Additive (scale)+import Foundation.Internal.Base+import Foundation.Internal.Proxy+import Foundation.Primitive+import Foundation.Numerical+import Foundation.Collection+import Foundation.Parser+import Foundation.String (String)+import Foundation.Bits++-- | IPv6 data type+data IPv6 = IPv6 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+  deriving (Eq, Ord, Typeable)+instance Hashable IPv6 where+    hashMix (IPv6 w1 w2) = hashMix w1 . hashMix w2+instance Show IPv6 where+    show = toLString+instance IsString IPv6 where+    fromString = fromLString+instance Storable IPv6 where+    peek ptr = fromTuple <$>+        (   (,,,,,,,)+        <$> (fromBE <$> peekOff ptr' 0)+        <*> (fromBE <$> peekOff ptr' 1)+        <*> (fromBE <$> peekOff ptr' 2)+        <*> (fromBE <$> peekOff ptr' 3)+        <*> (fromBE <$> peekOff ptr' 4)+        <*> (fromBE <$> peekOff ptr' 5)+        <*> (fromBE <$> peekOff ptr' 6)+        <*> (fromBE <$> peekOff ptr' 7)+        )+      where+        ptr' :: Ptr (BE Word16)+        ptr' = castPtr ptr+    poke ptr ipv6 = do+        let (i1,i2,i3,i4,i5,i6,i7,i8) = toTuple ipv6+         in pokeOff ptr' 0 (toBE i1)+         >> pokeOff ptr' 1 (toBE i2)+         >> pokeOff ptr' 2 (toBE i3)+         >> pokeOff ptr' 3 (toBE i4)+         >> pokeOff ptr' 4 (toBE i5)+         >> pokeOff ptr' 5 (toBE i6)+         >> pokeOff ptr' 6 (toBE i7)+         >> pokeOff ptr' 7 (toBE i8)+      where+        ptr' :: Ptr (BE Word16)+        ptr' = castPtr ptr+instance StorableFixed IPv6 where+    size      _ = (size      (Proxy :: Proxy Word64)) `scale` 2+    alignment _ = alignment (Proxy :: Proxy Word64)++-- | serialise to human readable IPv6+--+-- >>> toString (fromString "0:0:0:0:0:0:0:1" :: IPv6)+toString :: IPv6 -> String+toString = fromList . toLString++toLString :: IPv6 -> [Char]+toLString ipv4 =+    let (i1,i2,i3,i4,i5,i6,i7,i8) = toTuple ipv4+     in intercalate ":" $ showHex4 <$> [i1,i2,i3,i4,i5,i6,i7,i8]++showHex4 :: Word16 -> [Char]+showHex4 = showHex++showHex :: Word16 -> [Char]+showHex = Base.printf "%04x"++fromLString :: [Char] -> IPv6+fromLString = parseOnly ipv6Parser+++-- | create an IPv6 from the given tuple+fromTuple :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)+          -> IPv6+fromTuple (i1, i2, i3, i4, i5, i6, i7, i8) = IPv6 hi low+  where+    f :: Word16 -> Word64+    f = fromIntegral+    hi, low :: Word64+    hi =    (f i1 .<<. 48)+        .|. (f i2 .<<. 32)+        .|. (f i3 .<<. 16)+        .|. (f i4        )+    low =   (f i5 .<<. 48)+        .|. (f i6 .<<. 32)+        .|. (f i7 .<<. 16)+        .|. (f i8        )++-- | decompose an IPv6 into a tuple+toTuple :: IPv6 -> (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16)+toTuple (IPv6 hi low) =+    (f w1, f w2, f w3, f w4, f w5, f w6, f w7, f w8)+  where+    f :: Word64 -> Word16+    f = fromIntegral+    w1, w2, w3, w4, w5, w6, w7, w8 :: Word64+    w1 = hi  .>>. 48+    w2 = hi  .>>. 32+    w3 = hi  .>>. 16+    w4 = hi+    w5 = low .>>. 48+    w6 = low .>>. 32+    w7 = low .>>. 16+    w8 = low++-- | IPv6 Parser as described in RFC4291+--+-- for more details: https://tools.ietf.org/html/rfc4291.html#section-2.2+--+-- which is exactly:+--+-- ```+--     ipv6ParserPreferred+-- <|> ipv6ParserIPv4Embedded+-- <|> ipv6ParserCompressed+-- ```+--+ipv6Parser :: (Sequential input, Element input ~ Char)+           => Parser input IPv6+ipv6Parser =  ipv6ParserPreferred+          <|> ipv6ParserIpv4Embedded+          <|> ipv6ParserCompressed++-- | IPv6 parser as described in RFC4291 section 2.2.1+--+-- The preferred form is x:x:x:x:x:x:x:x, where the 'x's are one to+-- four hexadecimal digits of the eight 16-bit pieces of the address.+--+-- * `ABCD:EF01:2345:6789:ABCD:EF01:2345:6789`+-- * `2001:DB8:0:0:8:800:200C:417A`+--+ipv6ParserPreferred :: (Sequential input, Element input ~ Char)+                    => Parser input IPv6+ipv6ParserPreferred = do+    i1 <- takeAWord16 <* skipColon+    i2 <- takeAWord16 <* skipColon+    i3 <- takeAWord16 <* skipColon+    i4 <- takeAWord16 <* skipColon+    i5 <- takeAWord16 <* skipColon+    i6 <- takeAWord16 <* skipColon+    i7 <- takeAWord16 <* skipColon+    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+-- x:x:x:x:x:x:d.d.d.d, where the 'x's are the hexadecimal values of+-- the six high-order 16-bit pieces of the address, and the 'd's are+-- the decimal values of the four low-order 8-bit pieces of the+-- address (standard IPv4 representation).+--+-- * `0:0:0:0:0:0:13.1.68.3`+-- * `0:0:0:0:0:FFFF:129.144.52.38`+-- * `::13.1.68.3`+-- * `::FFFF:129.144.52.38`+--+ipv6ParserIpv4Embedded :: (Sequential input, Element input ~ Char)+                       => Parser input IPv6+ipv6ParserIpv4Embedded = do+    bs1 <- repeat (Between Never (toEnum 6)) $+              takeAWord16 <* skipColon+    _ <- optional skipColon+    _ <- optional skipColon+    bs2 <- repeat (Between Never (toEnum $ 6 - length bs1)) $+              takeAWord16 <* skipColon+    _ <- optional skipColon+    [i1,i2,i3,i4,i5,i6] <- format 6 bs1 bs2+    m1 <- takeAWord8 <* skipDot+    m2 <- takeAWord8 <* skipDot+    m3 <- takeAWord8 <* skipDot+    m4 <- takeAWord8+    return $ fromTuple ( i1,i2,i3,i4,i5,i6+                       , m1 `shiftL` 8 .|. m2+                       , m3 `shiftL` 8 .|. m4+                       )++-- | IPv6 parser as described in RFC4291 section 2.2.2+--+-- The use of "::" indicates one or more groups of 16 bits of zeros.+-- The "::" can only appear once in an address.  The "::" can also be+-- used to compress leading or trailing zeros in an address.+--+-- * `2001:DB8::8:800:200C:417A`+-- * `FF01::101`+-- * `::1`+-- * `::`+--+ipv6ParserCompressed :: (Sequential input, Element input ~ Char)+                     => Parser input IPv6+ipv6ParserCompressed = do+    bs1 <- repeat (Between Never (toEnum 8)) $+              takeAWord16 <* skipColon+    when (null bs1) skipColon+    bs2 <- repeat (Between Never (toEnum $ 8 - length bs1)) $+              skipColon *> takeAWord16+    [i1,i2,i3,i4,i5,i6,i7,i8] <- format 8 bs1 bs2+    return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8)++format :: (Integral a, Monad m) => Int -> [a] -> [a] -> m [a]+format sz bs1 bs2 = do+    let len = sz - length bs1 - length bs2+    when (len < 1) $ fail "invalid compressed IPv6 addressed"+    return $ bs1 <> replicate len 0 <> bs2++skipColon :: (Sequential input, Element input ~ Char)+          => Parser input ()+skipColon = element ':'+skipDot :: (Sequential input, Element input ~ Char)+        => Parser input ()+skipDot = element '.'+takeAWord8 :: (Sequential input, Element input ~ Char)+           => Parser input Word16+takeAWord8 = do+    read <$> repeat (Between Once (toEnum 3)) (satisfy isDigit)+takeAWord16 :: (Sequential input, Element input ~ Char)+            => Parser input Word16+takeAWord16 = do+    l <- repeat (Between Once (toEnum 4)) (satisfy isHexDigit)+    let lhs = readHex l+     in case lhs of+          [(w, [])] -> return w+          _ -> fail "can't fall here"

@@ -72,6 +72,12 @@ instance Signed Int64 where     abs = Prelude.abs     signum = orderingToSign . compare 0+instance Signed Float where+    abs = Prelude.abs+    signum = orderingToSign . compare 0+instance Signed Double where+    abs = Prelude.abs+    signum = orderingToSign . compare 0  class IntegralRounding a where     -- | Round up, to the next integral.

@@ -47,6 +47,9 @@     divMod :: a -> a -> (a, a)     divMod a b = (div a b, mod a b) +-- | Support for division between same types+--+-- This is likely to change to represent specific mathematic divisions class Multiplicative a => Divisible a where     {-# MINIMAL (/) #-}     (/) :: a -> a -> a

@@ -15,6 +15,7 @@     {-# MINIMAL toInteger #-}     toInteger :: a -> Integer +-- | Non Negative Number literals, convertible through the generic Natural type class (Enum a, Eq a, Ord a, Integral a, IsIntegral a) => IsNatural a where     {-# MINIMAL toNatural #-}     toNatural :: a -> Natural

@@ -12,12 +12,14 @@ import GHC.Int import qualified Prelude +-- | Convert an 'Int' into a 'Word' intToWord :: Int -> Word intToWord (I# i) = W# (int2Word# i) {-# INLINE intToWord #-} +-- | Various conversion between integral number class IntegralConvert a b where-    -- lossless integral convertion+    -- | lossless integral convertion     integralConvert :: a -> b  instance IntegralConvert Int8 Word8 where

@@ -26,9 +26,11 @@     -- * run the Parser     , parse     , parseFeed+    , parseOnly     -- * Parser methods     , hasMore     , element+    , satisfy     , anyElement     , elements     , string@@ -38,9 +40,10 @@     , skip     , skipWhile     , skipAll-    -- utils+    -- * utils     , optional-    , many, some+    , many, some, (<|>)+    , Count(..), Condition(..), repeat     ) where  import           Control.Applicative (Alternative, empty, (<|>), many, some, optional)@@ -57,6 +60,8 @@         , receivedInput :: !input            -- ^ but received this data         }+    | DoesNotSatify+        -- ^ some bytes didn't satisfy predicate     | NotEnough         -- ^ not enough data to complete the parser     | MonadFail String@@ -133,6 +138,25 @@       => Parser input a -> input -> Result input a parse p s = runParser p s (\_ msg -> ParseFail msg) ParseOK +-- | 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)+          => 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)+ -- When needing more data, getMore append the next data -- to the current buffer. if no further data, then -- the err callback is called.@@ -240,6 +264,14 @@         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 :: 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+ -- | Take elements while the @predicate hold from the current position in the -- stream takeWhile :: Sequential input => (Element input -> Bool) -> Parser input input@@ -276,3 +308,76 @@ -- stream skipAll :: Sequential input => Parser input () skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok++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)++data Condition = Exactly Count+               | Between Count Count+  deriving (Show)++shouldStop :: Condition -> Bool+shouldStop (Exactly   Never) = True+shouldStop (Between _ Never) = True+shouldStop _                 = False++canStop :: Condition -> Bool+canStop (Exactly Never)   = True+canStop (Between Never _) = True+canStop _                 = False++decrement :: Condition -> Condition+decrement (Exactly n)   = Exactly (pred n)+decrement (Between a b) = Between (pred a) (pred b)++-- | repeat the given Parser a given amount of time+--+-- If you know you want it to exactly perform a given amount of time:+--+-- ```+-- repeat (Exactly Twice) (element 'a')+-- ```+--+-- If you know your parser must performs from 0 to 8 times:+--+-- ```+-- repeat (Between Never (Other 8))+-- ```+--+-- *This interface is still WIP* but went handy when writting the IPv4/IPv6+-- parsers.+--+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

@@ -13,7 +13,13 @@ module Foundation.Primitive     ( PrimType(..)     , PrimMonad(..)++    -- * endianess+    , ByteSwap+    , LE(..), toLE, fromLE+    , BE(..), toBE, fromBE     ) where  import Foundation.Primitive.Types import Foundation.Primitive.Monad+import Foundation.Primitive.Endianness

@@ -0,0 +1,45 @@+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns  #-}+module Foundation.Primitive.Base16+    ( convertByte+    ) where++import GHC.Prim++-- | Convert a byte value in Word# to two Word#s containing+-- the hexadecimal representation of the Word#+--+-- Note that calling convertByte with a value greater than 256+-- will cause segfault or other horrible effect.+convertByte :: Word# -> (# Word#, Word# #)+convertByte b = (# r tableHi b, r tableLo b #)+  where+        r :: Table -> Word# -> Word#+        r (Table !table) index = indexWord8OffAddr# table (word2Int# index)+{-# INLINE convertByte #-}++data Table = Table Addr#++tableLo :: Table+tableLo = Table+    "0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef\+    \0123456789abcdef0123456789abcdef"#++tableHi :: Table+tableHi = Table+    "00000000000000001111111111111111\+    \22222222222222223333333333333333\+    \44444444444444445555555555555555\+    \66666666666666667777777777777777\+    \88888888888888889999999999999999\+    \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\+    \ccccccccccccccccdddddddddddddddd\+    \eeeeeeeeeeeeeeeeffffffffffffffff"#+

@@ -0,0 +1,84 @@+-- |+-- Module      : Foundation.Primitive.Endianness+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+-- Stability   : experimental+-- Portability : portable+--+-- Set endianness tag to a given primitive. This will help for serialising+-- data for protocols (such as the network protocols).+--++{-# LANGUAGE CPP #-}++module Foundation.Primitive.Endianness+    (+      ByteSwap+      -- * Big Endian+    , BE(..), toBE, fromBE+      -- * Little Endian+    , LE(..), toLE, fromLE+    ) where++import Foundation.Internal.Base+import Foundation.Internal.ByteSwap++#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)+import Foundation.System.Info (endianness, Endianness(..))+#endif++-- | Little Endian value+newtype LE a = LE { unLE :: a }+  deriving (Show, Eq, Typeable)+instance (ByteSwap a, Ord a) => Ord (LE a) where+    compare e1 e2 = compare (fromLE e1) (fromLE e2)++-- | Big Endian value+newtype BE a = BE { unBE :: a }+  deriving (Show, Eq, Typeable)+instance (ByteSwap a, Ord a) => Ord (BE a) where+    compare e1 e2 = compare (fromBE e1) (fromBE e2)++-- | Convert a value in cpu endianess to big endian+toBE :: ByteSwap a => a -> BE a+#ifdef ARCH_IS_LITTLE_ENDIAN+toBE = BE . byteSwap+#elif ARCH_IS_BIG_ENDIAN+toBE = BE+#else+toBE = BE . (if endianness == LittleEndian then byteSwap else id)+#endif+{-# INLINE toBE #-}++-- | Convert from a big endian value to the cpu endianness+fromBE :: ByteSwap a => BE a -> a+#ifdef ARCH_IS_LITTLE_ENDIAN+fromBE (BE a) = byteSwap a+#elif ARCH_IS_BIG_ENDIAN+fromBE (BE a) = a+#else+fromBE (BE a) = if endianness == LittleEndian then byteSwap a else a+#endif+{-# INLINE fromBE #-}++-- | Convert a value in cpu endianess to little endian+toLE :: ByteSwap a => a -> LE a+#ifdef ARCH_IS_LITTLE_ENDIAN+toLE = LE+#elif ARCH_IS_BIG_ENDIAN+toLE = LE . byteSwap+#else+toLE = LE . (if endianness == LittleEndian then id else byteSwap)+#endif+{-# INLINE toLE #-}++-- | Convert from a little endian value to the cpu endianness+fromLE :: ByteSwap a => LE a -> a+#ifdef ARCH_IS_LITTLE_ENDIAN+fromLE (LE a) = a+#elif ARCH_IS_BIG_ENDIAN+fromLE (LE a) = byteSwap a+#else+fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a+#endif+{-# INLINE fromLE #-}

@@ -30,9 +30,17 @@ import Foundation.Internal.Primitive import Foundation.Internal.Base +import Control.Monad.ST (runST)+ -- | Create a pointer with an associated finalizer data FinalPtr a = FinalPtr (Ptr a)                 | FinalForeign (ForeignPtr a)+instance Show (FinalPtr a) where+    show f = runST $ withFinalPtr f (return . show)+instance Eq (FinalPtr a) where+    (==) f1 f2 = runST (equal f1 f2)+instance Ord (FinalPtr a) where+    compare f1 f2 = runST (compare_ f1 f2)  -- | Check if 2 final ptr points on the same memory bits --@@ -83,3 +91,17 @@ withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f)) {-# NOINLINE withUnsafeFinalPtr #-}++equal :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Bool+equal f1 f2 =+    withFinalPtr f1 $ \ptr1 ->+    withFinalPtr f2 $ \ptr2 ->+        return $ ptr1 == ptr2+{-# INLINE equal #-}++compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering+compare_ f1 f2 =+    withFinalPtr f1 $ \ptr1 ->+    withFinalPtr f2 $ \ptr2 ->+        return $ ptr1 `compare` ptr2+{-# INLINE compare_ #-}

@@ -32,12 +32,12 @@ import           GHC.IORef import           GHC.IO import           GHC.Prim-import           Foundation.Internal.Base (Exception, (.), ($))+import           Foundation.Internal.Base (Exception, (.), ($), Applicative)  -- | Primitive monad that can handle mutation. -- -- For example: IO and ST.-class (Prelude.Functor m, Prelude.Monad m) => PrimMonad m where+class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where     -- | type of state token associated with the PrimMonad m     type PrimState m     -- | type of variable associated with the PrimMonad m

@@ -7,6 +7,8 @@ -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Foundation.Primitive.Types     ( PrimType(..)@@ -31,6 +33,7 @@ import           Foundation.Internal.Proxy import           Foundation.Internal.Base import           Foundation.Internal.Types+import           Foundation.Primitive.Endianness import           Foundation.Primitive.Monad import qualified Prelude (quot) @@ -387,6 +390,38 @@     {-# INLINE primAddrRead #-}     primAddrWrite addr (Offset n) (CUChar w8) = primAddrWrite addr (Offset n) w8     {-# INLINE primAddrWrite #-}++instance PrimType a => PrimType (LE a) where+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)+    {-# INLINE primSizeInBytes #-}+    primBaUIndex ba (Offset a) = LE $ primBaUIndex ba (Offset a)+    {-# INLINE primBaUIndex #-}+    primMbaURead ba (Offset a) = LE <$> primMbaURead ba (Offset a)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset a) (LE w) = primMbaUWrite mba (Offset a) w+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset a) = LE $ primAddrIndex addr (Offset a)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset a) = LE <$> primAddrRead addr (Offset a)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset a) (LE w) = primAddrWrite addr (Offset a) w+    {-# INLINE primAddrWrite #-}+instance PrimType a => PrimType (BE a) where+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)+    {-# INLINE primSizeInBytes #-}+    primBaUIndex ba (Offset a) = BE $ primBaUIndex ba (Offset a)+    {-# INLINE primBaUIndex #-}+    primMbaURead ba (Offset a) = BE <$> primMbaURead ba (Offset a)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset a) (BE w) = primMbaUWrite mba (Offset a) w+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset a) = BE $ primAddrIndex addr (Offset a)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset a) = BE <$> primAddrRead addr (Offset a)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset a) (BE w) = primAddrWrite addr (Offset a) w+    {-# INLINE primAddrWrite #-}+  -- | Cast a Size linked to type A (Size A) to a Size linked to type B (Size B) sizeRecast :: (PrimType a, PrimType b) => Size a -> Size b

@@ -83,6 +83,8 @@     maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO faster implementation     elem x = Data.List.elem x . toList     notElem x = Data.List.notElem x . toList+    all p = Data.List.all p . toList+    any p = Data.List.any p . toList instance C.Sequential AsciiString where     take = take     drop = drop

@@ -22,7 +22,8 @@ import GHC.Word import GHC.Types import Foundation.Array.Unboxed-import Foundation.Collection.Buildable+import Foundation.Array.Unboxed.Mutable (MUArray)+import Foundation.Boot.Builder  import Foundation.String.Encoding.Encoding @@ -78,9 +79,9 @@       => Char            -- ^ expecting it to be a valid Ascii character.            -- otherwise this function will throw an exception-      -> Builder (UArray Word8) st ()+      -> Builder (UArray Word8) (MUArray Word8) Word8 st () write c-    | c < toEnum 0x80 = append $ w8 c+    | c < toEnum 0x80 = builderAppend $ w8 c     | otherwise       = throw $ CharNotAscii c   where     w8 :: Char -> Word8

@@ -13,14 +13,14 @@     , convertFromTo     ) where -import Foundation.Internal.Base-import Foundation.Internal.Types-import Foundation.Primitive.Monad-import Foundation.Primitive.Types-import Foundation.Numerical-import qualified Foundation.Collection as C-import           Foundation.Collection.Buildable+import           Foundation.Internal.Base+import           Foundation.Internal.Types+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Types+import           Foundation.Boot.Builder+import           Foundation.Numerical import           Foundation.Array.Unboxed (UArray)+import           Foundation.Array.Unboxed.Mutable (MUArray) import qualified Foundation.Array.Unboxed as Vec  class Encoding encoding where@@ -47,8 +47,7 @@                 -> Offset (Unit encoding)                       -- ^ offset of the `Unit encoding` where starts the                       -- encoding of a given unicode-                -> Either (Error encoding) (Char, Offset (Unit encoding))-                      -- ^ either successfully validated the `Unit encoding`+                -> Either (Error encoding) (Char, Offset (Unit encoding)) -- ^ either successfully validated the `Unit encoding`                       -- and returned the next offset or fail with an                       -- `Error encoding` @@ -61,7 +60,9 @@                       -- ^ only used for type deduction                   -> Char                       -- ^ the unicode character to encode-                  -> Builder (UArray (Unit encoding)) st ()+                  -> Builder (UArray (Unit encoding))+                             (MUArray (Unit encoding))+                             (Unit encoding) st ()  -- | helper to convert a given Array in a given encoding into an array -- with another encoding.@@ -90,10 +91,10 @@                 -- ^ the input raw array               -> st (UArray (Unit output)) convertFromTo inputEncodingTy outputEncodingTy bytes-    | C.null bytes = return mempty-    | otherwise    = Vec.unsafeIndexer bytes $ \t -> build 64 (loop azero t)+    | Vec.null bytes = return mempty+    | otherwise      = Vec.unsafeIndexer bytes $ \t -> Vec.builderBuild 64 (loop azero t)   where-    lastUnit = Offset $ C.length bytes+    lastUnit = Offset $ Vec.length bytes      loop off getter       | off >= lastUnit = return ()

@@ -22,7 +22,8 @@ import GHC.Word import GHC.Types import Foundation.Array.Unboxed-import Foundation.Collection.Buildable+import Foundation.Array.Unboxed.Mutable (MUArray)+import Foundation.Boot.Builder  import Foundation.String.Encoding.Encoding @@ -54,9 +55,9 @@  write :: (PrimMonad st, Monad st)       => Char-      -> Builder (UArray Word8) st ()+      -> Builder (UArray Word8) (MUArray Word8) Word8 st () write c@(C# ch)-    | c <= toEnum 0xFF = append (W8# x)+    | c <= toEnum 0xFF = builderAppend (W8# x)     | otherwise        = throw $ NotISO_8859_1 c   where     x :: Word#

@@ -21,7 +21,8 @@ import Data.Bits import qualified Prelude import Foundation.Array.Unboxed-import Foundation.Collection.Buildable+import Foundation.Array.Unboxed.Mutable (MUArray)+import Foundation.Boot.Builder  import Foundation.String.Encoding.Encoding @@ -76,12 +77,12 @@  write :: (PrimMonad st, Monad st)       => Char-      -> Builder (UArray Word16) st ()+      -> Builder (UArray Word16) (MUArray Word16) Word16 st () write c-    | c < toEnum 0xd800   = append $ w16 c-    | c > toEnum 0x10000  = let (w1, w2) = wHigh c in append w1 >> append w2+    | c < toEnum 0xd800   = builderAppend $ w16 c+    | c > toEnum 0x10000  = let (w1, w2) = wHigh c in builderAppend w1 >> builderAppend w2     | c > toEnum 0x10ffff = throw $ InvalidUnicode c-    | c >= toEnum 0xe000  = append $ w16 c+    | c >= toEnum 0xe000  = builderAppend $ w16 c     | otherwise = throw $ InvalidUnicode c   where     w16 :: Char -> Word16

@@ -19,7 +19,8 @@ import GHC.Types import Foundation.Numerical import Foundation.Array.Unboxed-import Foundation.Collection.Buildable+import Foundation.Array.Unboxed.Mutable (MUArray)+import Foundation.Boot.Builder  import Foundation.String.Encoding.Encoding @@ -46,8 +47,8 @@  write :: (PrimMonad st, Monad st)       => Char-      -> Builder (UArray Word32) st ()-write c = append w32+      -> Builder (UArray Word32) (MUArray Word32) Word32 st ()+write c = builderAppend w32   where     !(C# ch) = c     w32 :: Word32

@@ -28,7 +28,6 @@ import           Foundation.Internal.Types import qualified Foundation.Array.Unboxed as Vec import           Foundation.Array.Unboxed (UArray)-import           Foundation.Collection.Buildable import           Foundation.Numerical import           Foundation.Primitive.FinalPtr import           Foundation.String.UTF8Table@@ -62,13 +61,13 @@     ba <- buildByteArray addr     Vec.unsafeIndexer ba buildWithBytes   where-    buildWithBytes getAt = build 64 $ loopBuilder getAt (Offset 0)+    buildWithBytes getAt = Vec.builderBuild 64 $ loopBuilder getAt (Offset 0)     loopBuilder getAt offset =         case bs of             [] -> internalError "ModifiedUTF8.fromModified"             [0x00] -> return ()-            [b1,b2] | b1 == 0xC0 && b2 == 0x80 -> append 0x00 >> loopBuilder getAt noffset-            _ -> mapM_ append bs >> loopBuilder getAt noffset+            [b1,b2] | b1 == 0xC0 && b2 == 0x80 -> Vec.builderAppend 0x00 >> loopBuilder getAt noffset+            _ -> mapM_ Vec.builderAppend bs >> loopBuilder getAt noffset       where         (bs, noffset) = accessBytes offset getAt 

@@ -23,9 +23,10 @@ {-# LANGUAGE CPP                        #-} module Foundation.String.UTF8     ( String(..)-    --, Buffer+    , MutableString(..)     , create     , replicate+    , length     -- * Binary conversion     , Encoding(..)     , fromBytes@@ -36,6 +37,35 @@     , mutableValidate     , copy     , ValidationFailure(..)+    , index+    , sToList+    , null+    , drop+    , take+    , splitAt+    , revDrop+    , revTake+    , revSplitAt+    , splitOn+    , sub+    , elem+    , intersperse+    , span+    , break+    , breakElem+    , singleton+    , charMap+    , snoc+    , cons+    , unsnoc+    , uncons+    , find+    , findIndex+    , sortBy+    , filter+    , reverse+    , builderAppend+    , builderBuild     -- * Legacy utility     , lines     , words@@ -43,10 +73,9 @@  import           Foundation.Array.Unboxed           (UArray) import qualified Foundation.Array.Unboxed           as Vec+import qualified Foundation.Array.Unboxed           as C import           Foundation.Array.Unboxed.ByteArray (MutableByteArray) import qualified Foundation.Array.Unboxed.Mutable   as MVec-import qualified Foundation.Collection              as C-import           Foundation.Collection.Buildable import           Foundation.Internal.Base import           Foundation.Internal.MonadTrans import           Foundation.Internal.Primitive@@ -54,12 +83,16 @@ import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Primitive.Types+import           Foundation.Boot.Builder+import qualified Foundation.Boot.List as List import           Foundation.String.UTF8Table import           GHC.Prim import           GHC.ST import           GHC.Types import           GHC.Word+#if MIN_VERSION_base(4,9,0) import           GHC.Char+#endif   -- temporary import qualified Data.List@@ -88,6 +121,13 @@ stringType :: DataType stringType = mkNoRepType "Foundation.String" +-- | Mutable String Buffer.+--+-- Note that it's hard to use properly since the UTF8 encoding+-- is variable, and thus you can't mutable previously filled+-- data without potentially have to move all the data around.+--+-- See 'charMap' for an idea of the scale of the problem newtype MutableString st = MutableString (MutableByteArray st)     deriving (Typeable) @@ -100,87 +140,7 @@     fromList = sFromList     toList = sToList -type instance C.Element String = Char--instance C.InnerFunctor String where-    imap = charMap-instance C.Collection String where-    null = null-    length = length-    elem = elem-    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO faster implementation-    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO faster implementation-instance C.Sequential String where-    take = take-    drop = drop-    splitAt = splitAt-    revTake = revTake-    revDrop = revDrop-    revSplitAt = revSplitAt-    splitOn = splitOn-    break = break-    breakElem = breakElem-    intersperse = intersperse-    span = span-    filter = filter-    reverse = reverse-    unsnoc = unsnoc-    uncons = uncons-    snoc = snoc-    cons = cons-    find = find-    sortBy = sortBy-    singleton = fromList . (:[])--instance C.Zippable String where-  zipWith f as bs = runST $ build 64 $ go f (toList as) (toList bs)-    where-      go _  []       _        = return ()-      go _  _        []       = return ()-      go f' (a':as') (b':bs') = append (f' a' b') >> go f' as' bs'--instance Buildable String where-  type Mutable String = MutableString-  type Step String = Word8--  append c = Builder $ State $ \(i, st) ->-      if offsetAsSize i + nbBytes >= chunkSize st-          then do-              cur      <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)-              newChunk <- new (chunkSize st)-              writeUTF8Char newChunk (Offset 0) utf8Char-              return ((), (sizeAsOffset nbBytes, st { prevChunks     = cur : prevChunks st-                                                    , prevChunksSize = offsetAsSize i + prevChunksSize st-                                                    , curChunk       = newChunk-                                                    }))-          else do-              writeUTF8Char (curChunk st) i utf8Char-              return ((), (i + sizeAsOffset nbBytes, st))-    where-      utf8Char = asUTF8Char c-      nbBytes  = numBytes utf8Char-  {-# INLINE append #-}--  build sizeChunksI sb-    | sizeChunksI <= 3 = build 64 sb-    | otherwise        = do-        first         <- new sizeChunks-        ((), (i, st)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (Size 0) first sizeChunks)-        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)-        -- Build final array-        let totalSize = prevChunksSize st + offsetAsSize i-        final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze-        return $ String final-    where-      sizeChunks = Size sizeChunksI--      fillFromEnd _   []            mba = return mba-      fillFromEnd !end (String x:xs) mba = do-          let sz = Vec.lengthSize x-          Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz-          fillFromEnd (end - sz) xs mba-  {-# INLINE build #-}-+-- | Possible failure related to validating bytes of UTF8 sequences. data ValidationFailure = InvalidHeader                        | InvalidContinuation                        | MissingByte@@ -188,6 +148,7 @@  instance Exception ValidationFailure +-- | UTF8 Encoder data EncoderUTF8 = EncoderUTF8  instance Encoder.Encoding EncoderUTF8 where@@ -248,6 +209,7 @@             !nbContsE@(Size nbConts) = Size $ getNbBytes h     {-# INLINE go #-} +-- | Similar to 'validate' but works on a 'MutableByteArray' mutableValidate :: PrimMonad prim                 => MutableByteArray (PrimState prim)                 -> Int@@ -268,7 +230,7 @@                 (pos, Just failure) -> return (pos, Just failure)      one pos = do-        h <- C.mutUnsafeRead mba pos+        h <- Vec.unsafeRead mba pos         let nbConts = getNbBytes h         if nbConts == 0xff             then return (pos, Just InvalidHeader)@@ -278,20 +240,20 @@                     case nbConts of                         0 -> return (pos + 1, Nothing)                         1 -> do-                            c1 <- C.mutUnsafeRead mba (pos + 1)+                            c1 <- Vec.unsafeRead mba (pos + 1)                             if isContinuation c1                                 then return (pos + 2, Nothing)                                 else return (pos, Just InvalidContinuation)                         2 -> do-                            c1 <- C.mutUnsafeRead mba (pos + 1)-                            c2 <- C.mutUnsafeRead mba (pos + 2)+                            c1 <- Vec.unsafeRead mba (pos + 1)+                            c2 <- Vec.unsafeRead mba (pos + 2)                             if isContinuation c1 && isContinuation c2                                 then return (pos + 3, Nothing)                                 else return (pos, Just InvalidContinuation)                         3 -> do-                            c1 <- C.mutUnsafeRead mba (pos + 1)-                            c2 <- C.mutUnsafeRead mba (pos + 2)-                            c3 <- C.mutUnsafeRead mba (pos + 3)+                            c1 <- Vec.unsafeRead mba (pos + 1)+                            c2 <- Vec.unsafeRead mba (pos + 2)+                            c3 <- Vec.unsafeRead mba (pos + 3)                             if isContinuation c1 && isContinuation c2 && isContinuation c3                                 then return (pos + 4, Nothing)                                 else return (pos, Just InvalidContinuation)@@ -347,7 +309,7 @@  writeWithBuilder :: (PrimMonad st, Monad st)                  => Char-                 -> Builder (UArray Word8) st ()+                 -> 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@@ -357,25 +319,25 @@     !(I# xi) = fromEnum c     !x       = int2Word# xi -    encode1 = append (W8# x)+    encode1 = Vec.builderAppend (W8# x)      encode2 = do         let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##             x2  = toContinuation x-        append (W8# x1) >> append (W8# x2)+        Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2)      encode3 = do         let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##             x2  = toContinuation (uncheckedShiftRL# x 6#)             x3  = toContinuation x-        append (W8# x1) >> append (W8# x2) >> append (W8# x3)+        Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3)      encode4 = do         let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##             x2  = toContinuation (uncheckedShiftRL# x 12#)             x3  = toContinuation (uncheckedShiftRL# x 6#)             x4  = toContinuation x-        append (W8# x1) >> append (W8# x2) >> append (W8# x3) >> append (W8# x4)+        Vec.builderAppend (W8# x1) >> Vec.builderAppend (W8# x2) >> Vec.builderAppend (W8# x3) >> Vec.builderAppend (W8# x4)      toContinuation :: Word# -> Word#     toContinuation w = or# (and# w 0x3f##) 0x80##@@ -462,19 +424,19 @@  writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim () writeUTF8Char (MutableString mba) (Offset i) (UTF8_1 x1) =-        C.mutUnsafeWrite mba i     x1+    Vec.unsafeWrite mba i     x1 writeUTF8Char (MutableString mba) (Offset i) (UTF8_2 x1 x2) = do-        C.mutUnsafeWrite mba i     x1-        C.mutUnsafeWrite mba (i+1) x2+    Vec.unsafeWrite mba i     x1+    Vec.unsafeWrite mba (i+1) x2 writeUTF8Char (MutableString mba) (Offset i) (UTF8_3 x1 x2 x3) = do-        C.mutUnsafeWrite mba i     x1-        C.mutUnsafeWrite mba (i+1) x2-        C.mutUnsafeWrite mba (i+2) x3+    Vec.unsafeWrite mba i     x1+    Vec.unsafeWrite mba (i+1) x2+    Vec.unsafeWrite mba (i+2) x3 writeUTF8Char (MutableString mba) (Offset i) (UTF8_4 x1 x2 x3 x4) = do-        C.mutUnsafeWrite mba i     x1-        C.mutUnsafeWrite mba (i+1) x2-        C.mutUnsafeWrite mba (i+2) x3-        C.mutUnsafeWrite mba (i+3) x4+    Vec.unsafeWrite mba i     x1+    Vec.unsafeWrite mba (i+1) x2+    Vec.unsafeWrite mba (i+2) x3+    Vec.unsafeWrite mba (i+3) x4 {-# INLINE writeUTF8Char #-}  write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8@@ -487,22 +449,22 @@     !(I# xi) = fromEnum c     !x       = int2Word# xi -    encode1 = C.mutUnsafeWrite mba i (W8# x) >> return (Offset $ i + 1)+    encode1 = Vec.unsafeWrite mba i (W8# x) >> return (Offset $ i + 1)      encode2 = do         let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##             x2  = toContinuation x-        C.mutUnsafeWrite mba i     (W8# x1)-        C.mutUnsafeWrite mba (i+1) (W8# x2)+        Vec.unsafeWrite mba i     (W8# x1)+        Vec.unsafeWrite mba (i+1) (W8# x2)         return $ Offset (i + 2)      encode3 = do         let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##             x2  = toContinuation (uncheckedShiftRL# x 6#)             x3  = toContinuation x-        C.mutUnsafeWrite mba i     (W8# x1)-        C.mutUnsafeWrite mba (i+1) (W8# x2)-        C.mutUnsafeWrite mba (i+2) (W8# x3)+        Vec.unsafeWrite mba i     (W8# x1)+        Vec.unsafeWrite mba (i+1) (W8# x2)+        Vec.unsafeWrite mba (i+2) (W8# x3)         return $ Offset (i + 3)      encode4 = do@@ -510,10 +472,10 @@             x2  = toContinuation (uncheckedShiftRL# x 12#)             x3  = toContinuation (uncheckedShiftRL# x 6#)             x4  = toContinuation x-        C.mutUnsafeWrite mba i     (W8# x1)-        C.mutUnsafeWrite mba (i+1) (W8# x2)-        C.mutUnsafeWrite mba (i+2) (W8# x3)-        C.mutUnsafeWrite mba (i+3) (W8# x4)+        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 $ Offset (i + 4)      toContinuation :: Word# -> Word#@@ -531,6 +493,9 @@ ------------------------------------------------------------------------ -- real functions +-- | Convert a String to a list of characters+--+-- The list is lazily created as evaluation needed sToList :: String -> [Char] sToList s = loop azero   where@@ -550,11 +515,16 @@   sFromList (unpackCStringUtf8# s) = String $ fromModified s   #-} +-- | Create a new String from a list of characters+--+-- The list is strictly and fully evaluated before+-- creating the new String, as the size need to be+-- computed before filling. sFromList :: [Char] -> String sFromList l = runST (new bytes >>= startCopy)   where     -- count how many bytes-    !bytes = C.foldl' (+) (Size 0) $ fmap (charToBytes . fromEnum) l+    !bytes = List.sum $ fmap (charToBytes . fromEnum) l      startCopy :: MutableString (PrimState (ST st)) -> ST st String     startCopy ms = loop azero l@@ -563,12 +533,13 @@         loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs {-# INLINE [0] sFromList #-} +-- | Check if a String is null null :: String -> Bool null (String ba) = C.length ba == 0  -- | Create a string composed of a number @n of Chars (Unicode code points). ----- if the input @s contains less characters than required, then+-- if the input @s contains less characters than required, then the input string is returned. take :: Int -> String -> String take n s@(String ba)     | n <= 0           = mempty@@ -582,6 +553,8 @@     | n >= C.length ba = mempty     | otherwise        = let (Offset o) = indexN n s in String $ Vec.drop o ba +-- | Split a string at the Offset specified (in Char) returning both+-- the leading part and the remaining part. splitAt :: Int -> String -> (String, String) splitAt nI s@(String ba)     | nI <= 0           = (mempty, s)@@ -625,12 +598,15 @@ -- rev{Take,Drop,SplitAt} TODO optimise: -- we can process the string from the end using a skipPrev instead of getting the length +-- | Similar to 'take' but from the end revTake :: Int -> String -> String revTake nbElems v = drop (length v - nbElems) v +-- | Similar to 'drop' but from the end revDrop :: Int -> String -> String revDrop nbElems v = take (length v - nbElems) v +-- | Similar to 'splitAt' but from the end revSplitAt :: Int -> String -> (String, String) revSplitAt n v = (drop idx v, take idx v)   where idx = length v - n@@ -660,14 +636,22 @@                     then sub s prevIdx idx : loop idx' idx'                     else loop prevIdx idx' +-- | Internal call to make a substring given offset in bytes.+--+-- This is unsafe considering that one can create a substring+-- starting and/or ending on the middle of a UTF8 sequence. sub :: String -> Offset8 -> Offset8 -> String sub (String ba) (Offset start) (Offset end) = String $ Vec.sub ba start end --- | Split at a given index.+-- | Internal call to split at a given index in offset of bytes.+--+-- This is unsafe considering that one can split in the middle of a+-- UTF8 sequence, so use with care. splitIndex :: Offset8 -> String -> (String, String) splitIndex (Offset idx) (String ba) = (String v1, String v2)   where (v1,v2) = C.splitAt idx ba +-- | Break a string into 2 strings at the location where the predicate return True break :: (Char -> Bool) -> String -> (String, String) break predicate s@(String ba) = runST $ Vec.unsafeIndexer ba go   where@@ -694,6 +678,7 @@ {-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-} #endif +-- | Break a string into 2 strings at the first occurence of the character breakElem :: Char -> String -> (String, String) breakElem !el s@(String ba) =     case asUTF8Char el of@@ -715,6 +700,12 @@                     True  -> return $ splitIndex idx s                     False -> loop idx' +-- | Apply a @predicate@ to the string to return the longest prefix that satisfy the predicate and+-- the remaining+span :: (Char -> Bool) -> String -> (String, String)+span predicate s = break (not . predicate) s++-- | Return whereas the string contains a specific character or not elem :: Char -> String -> Bool elem !el s@(String ba) =     case asUTF8Char el of@@ -736,6 +727,10 @@                     True  -> return True                     False -> loop idx' +-- | Intersperse the character @sep@ between each character in the string+--+-- > intersperse ' ' "Hello Foundation"+-- "H e l l o   F o u n d a t i o n" intersperse :: Char -> String -> String intersperse sep src     | srcLen <= 1 = src@@ -777,13 +772,15 @@         | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx                          fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst' -span :: (Char -> Bool) -> String -> (String, String)-span predicate s = break (not . predicate) s---- | size in bytes+-- | size in bytes.+--+-- this size is available in o(1) size :: String -> Size8 size (String ba) = Size $ C.length ba +-- | Length of a String using Size+--+-- this size is available in o(n) lengthSize :: String -> Size Char lengthSize (String ba)     | C.null ba = Size 0@@ -805,9 +802,11 @@             | otherwise  = loop (idx `offsetPlusE` d) (i + Size 1)           where d = skipNextHeaderValue (primAddrIndex ptr idx) +-- | Length of a string in number of characters length :: String -> Int length s = let (Size sz) = lengthSize s in sz +-- | Replicate a character @c@ @n@ times to create a string of length @n@ replicate :: Int -> Char -> String replicate n c = runST (new nbBytes >>= fill)   where@@ -822,22 +821,39 @@             | otherwise  = write ms idx c >>= loop  -- | Copy the String+--+-- The slice of memory is copied to a new slice, making the new string+-- independent from the original string.. copy :: String -> String copy (String s) = String (Vec.copy s) +-- | Create a single element String+singleton :: Char -> String+singleton c = runST $ do+    ms <- new nbBytes+    _  <- write ms (Offset 0) c+    freeze ms+  where+    !nbBytes = charToBytes (fromEnum c)+ -- | Allocate a MutableString of a specific size in bytes. new :: PrimMonad prim     => Size8 -- ^ in number of bytes, not of elements.     -> prim (MutableString (PrimState prim)) new n = MutableString `fmap` MVec.new n +-- | Unsafely create a string of up to @sz@ bytes.+--+-- The callback @f@ needs to return the number of bytes filled in the underlaying+-- bytes buffer. No check is made on the callback return values, and if it's not+-- contained without the bounds, bad things will happen. create :: PrimMonad prim => Int -> (MutableString (PrimState prim) -> prim Int) -> prim String create sz f = do     ms     <- new (Size sz)     filled <- f ms     if filled == sz         then freeze ms-        else C.take filled `fmap` freeze ms+        else take filled `fmap` freeze ms  charToBytes :: Int -> Size8 charToBytes c@@ -847,6 +863,7 @@     | c < 0x110000 = Size 4     | otherwise    = error ("invalid code point: " `mappend` show c) +-- | Monomorphically map the character in a string and return the transformed one charMap :: (Char -> Char) -> String -> String charMap f src =     let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (Size 0)@@ -906,9 +923,10 @@         Vec.unsafeCopyAtRO mba start ba (Offset 0) sz         copyLoop ms xs start +-- | Append a Char to the end of the String and return this new String snoc :: String -> Char -> String snoc s@(String ba) c-    | len == Size 0 = C.singleton c+    | len == Size 0 = singleton c     | otherwise     = runST $ do         ms@(MutableString mba) <- new (len + nbBytes)         Vec.unsafeCopyAtRO mba (Offset 0) ba (Offset 0) len@@ -918,9 +936,10 @@     !len     = size s     !nbBytes = charToBytes (fromEnum c) +-- | Prepend a Char to the beginning of the String and return this new String cons :: Char -> String -> String cons c s@(String ba)-  | len == Size 0 = C.singleton c+  | len == Size 0 = singleton c   | otherwise     = runST $ do       ms@(MutableString mba) <- new (len + nbBytes)       idx <- write ms (Offset 0) c@@ -930,6 +949,9 @@     !len     = size s     !nbBytes = charToBytes (fromEnum c) +-- | Extract the String stripped of the last character and the last character if not empty+--+-- If empty, Nothing is returned unsnoc :: String -> Maybe (String, Char) unsnoc s     | null s    = Nothing@@ -939,6 +961,9 @@                 [c] -> Just (s2, c)                 _   -> internalError "unsnoc" +-- | 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     | null s    = Nothing@@ -948,6 +973,7 @@                 [c] -> Just (c, s2)                 _   -> internalError "uncons" +-- | Look for a predicate in the String and return the matched character, if any. find :: (Char -> Bool) -> String -> Maybe Char find predicate s = loop (Offset 0)   where@@ -961,12 +987,15 @@                     True  -> Just c                     False -> loop idx' +-- | Sort the character in a String using a specific sort function 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 +-- | Reverse a string reverse :: String -> String reverse s@(String ba) = runST $ do     ms <- new len@@ -982,29 +1011,61 @@                 !nb = Size (getNbBytes h + 1)                 didx'@(Offset d) = didx `offsetMinusE` nb             case nb of-                Size 1 -> C.mutUnsafeWrite mba d      h+                Size 1 -> Vec.unsafeWrite mba d      h                 Size 2 -> do-                    C.mutUnsafeWrite mba d       h-                    C.mutUnsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))+                    Vec.unsafeWrite mba d       h+                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))                 Size 3 -> do-                    C.mutUnsafeWrite mba d       h-                    C.mutUnsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))-                    C.mutUnsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))+                    Vec.unsafeWrite mba d       h+                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex ba (si + 1))+                    Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))                 Size 4 -> do-                    C.mutUnsafeWrite mba d       h-                    C.mutUnsafeWrite mba (d + 1) (Vec.unsafeIndex  ba (si + 1))-                    C.mutUnsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))-                    C.mutUnsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3))+                    Vec.unsafeWrite mba d       h+                    Vec.unsafeWrite mba (d + 1) (Vec.unsafeIndex  ba (si + 1))+                    Vec.unsafeWrite mba (d + 2) (Vec.unsafeIndex ba (si + 2))+                    Vec.unsafeWrite mba (d + 3) (Vec.unsafeIndex ba (si + 3))                 _  -> return () -- impossible             loop ms (sidx `offsetPlusE` nb) didx' +-- | Return the nth character in a String+--+-- Compared to an array, the string need to be scanned from the beginning+-- since the UTF8 encoding is variable.+index :: String -> Int -> Maybe Char+index s n+    | ofs >= end = Nothing+    | otherwise  =+        let (# c, _ #) = next s ofs+         in Just c+  where+    !nbBytes = size s+    end = 0 `offsetPlusE` nbBytes+    ofs = indexN n s++-- | Return the index in unit of Char of the first occurence of the predicate returning True+--+-- If not found, Nothing is returned+findIndex :: (Char -> Bool) -> String -> Maybe Int+findIndex predicate s = loop (Offset 0)+  where+    !sz = size s+    end = Offset 0 `offsetPlusE` sz+    loop idx+        | idx == end = Nothing+        | otherwise =+            let (# c, idx' #) = next s idx+             in case predicate c of+                    True  -> let (Offset r) = idx in Just r+                    False -> loop idx'++-- | Various String Encoding that can be use to convert to and from bytes data Encoding     = ASCII7     | UTF8     | UTF16     | UTF32     | ISO_8859_1-  deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded)+    deriving (Typeable, Data, Eq, Ord, Show, Enum, Bounded)  fromEncoderBytes :: ( Encoder.Encoding encoding                     , Exception (Encoder.Error encoding)@@ -1081,6 +1142,10 @@     replacement :: String     !replacement = fromBytesUnsafe $ fromList [0xef,0xbf,0xbd] +-- | Decode a stream of binary chunks containing UTF8 encoding in a list of valid String+--+-- Chunk not necessarily contains a valid string, as+-- a UTF8 sequence could be split over 2 chunks. fromChunkBytes :: [UArray Word8] -> [String] fromChunkBytes l = loop l   where@@ -1127,8 +1192,53 @@ toBytes UTF16      (String bytes) = toEncoderBytes Encoder.UTF16      bytes toBytes UTF32      (String bytes) = toEncoderBytes Encoder.UTF32      bytes +-- | Split lines in a string using newline as separation lines :: String -> [String] lines = fmap fromList . Prelude.lines . toList +-- | Split words in a string using spaces as separation+--+-- > words "Hello Foundation"+-- [ "Hello", "Foundation" ] words :: String -> [String] 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) ->+    if offsetAsSize i + nbBytes >= chunkSize st+        then do+            cur      <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+            newChunk <- new (chunkSize st)+            writeUTF8Char newChunk (Offset 0) utf8Char+            return ((), (sizeAsOffset nbBytes, st { prevChunks     = cur : prevChunks st+                                                  , prevChunksSize = offsetAsSize i + prevChunksSize st+                                                  , curChunk       = newChunk+                                                  }))+        else do+            writeUTF8Char (curChunk st) i utf8Char+            return ((), (i + sizeAsOffset nbBytes, st))+  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 sizeChunksI sb+    | sizeChunksI <= 3 = builderBuild 64 sb+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+        -- Build final array+        let totalSize = prevChunksSize st + offsetAsSize i+        final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze+        return $ String final+  where+    sizeChunks = Size sizeChunksI++    fillFromEnd _   []            mba = return mba+    fillFromEnd !end (String x:xs) mba = do+        let sz = Vec.lengthSize x+        Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz+        fillFromEnd (end - sz) xs mba

@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+module Foundation.System.Bindings+    ( module X+    ) where++#ifdef mingw32_HOST_OS+import Foundation.System.Bindings.Windows as X+#else+import Foundation.System.Bindings.Posix as X+#endif

@@ -0,0 +1,7 @@+module Foundation.System.Bindings.Hs+    where++import GHC.IO+import Foreign.C.Types++foreign import ccall unsafe "HsBase.h __hscore_get_errno" sysHsCoreGetErrno :: IO CInt

@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Foundation.System.Bindings.Linux+-- Copyright   :  (c) Vincent Hanquez 2014-2017+-- License     :  BSD-style+--+-- Maintainer  :  Vincent Hanquez+-- Stability   :  provisional+-- Portability :  non-portable (requires Linux)+--+-- Functions defined only for linux+--+-----------------------------------------------------------------------------++module Foundation.System.Bindings.Linux+   where++import Foundation.Internal.Base+import Foreign.C.Types+import Foundation.System.Bindings.PosixDef+import Foundation.System.Bindings.Posix++#define __USE_GNU++#include <sys/types.h>+#include <sys/inotify.h>+#include <fcntl.h>++type CInotifyFlags = CInt+type CInotifyMask = CInt+type CWatchDescriptor = CInt++sysLinux_O_TMPFILE+    :: COpenFlags+#ifdef __O_TMPFILE+sysLinux_O_TMPFILE   = (#const __O_TMPFILE)+#else+sysLinux_O_TMPFILE   = 0+#endif++sysLinux_IN_NONBLOCK+    , sysLinux_IN_CLOEXEC :: CInotifyFlags+sysLinux_IN_NONBLOCK = (#const IN_NONBLOCK)+sysLinux_IN_CLOEXEC  = (#const IN_CLOEXEC)++sysLinux_IN_ACCESS+    , sysLinux_IN_ATTRIB+    , sysLinux_IN_CLOSE_WRITE+    , sysLinux_IN_CLOSE_NOWRITE+    , sysLinux_IN_CREATE+    , sysLinux_IN_DELETE+    , sysLinux_IN_DELETE_SELF+    , sysLinux_IN_MODIFY+    , sysLinux_IN_MOVE_SELF+    , sysLinux_IN_MOVED_FROM+    , sysLinux_IN_MOVED_TO :: CInotifyMask+sysLinux_IN_ACCESS = (#const IN_ACCESS)+sysLinux_IN_ATTRIB = (#const IN_ATTRIB)+sysLinux_IN_CLOSE_WRITE = (#const IN_CLOSE_WRITE)+sysLinux_IN_CLOSE_NOWRITE = (#const IN_CLOSE_NOWRITE)+sysLinux_IN_CREATE = (#const IN_CREATE)+sysLinux_IN_DELETE = (#const IN_DELETE)+sysLinux_IN_DELETE_SELF = (#const IN_DELETE_SELF)+sysLinux_IN_MODIFY = (#const IN_MODIFY)+sysLinux_IN_MOVE_SELF = (#const IN_MOVE_SELF)+sysLinux_IN_MOVED_FROM = (#const IN_MOVED_FROM)+sysLinux_IN_MOVED_TO = (#const IN_MOVED_TO)++-- extra mask at add_watch time+sysLinux_IN_OPEN+    , sysLinux_IN_DONT_FOLLOW+    , sysLinux_IN_EXCL_UNLINK+    , sysLinux_IN_MASK_ADD+    , sysLinux_IN_ONESHOT+    , sysLinux_IN_ONLYDIR :: CInotifyMask+sysLinux_IN_OPEN = (#const IN_OPEN)+sysLinux_IN_DONT_FOLLOW = (#const IN_DONT_FOLLOW)+sysLinux_IN_EXCL_UNLINK = (#const IN_EXCL_UNLINK)+sysLinux_IN_MASK_ADD = (#const IN_MASK_ADD)+sysLinux_IN_ONESHOT = (#const IN_ONESHOT)+sysLinux_IN_ONLYDIR = (#const IN_ONLYDIR)++-- only found in mask+sysLinux_IN_IGNORED+    , sysLinux_IN_ISDIR+    , sysLinux_IN_Q_OVERFLOW+    , sysLinux_IN_UNMOUNT :: CInotifyMask+sysLinux_IN_IGNORED = (#const IN_IGNORED)+sysLinux_IN_ISDIR = (#const IN_ISDIR)+sysLinux_IN_Q_OVERFLOW = (#const IN_Q_OVERFLOW)+sysLinux_IN_UNMOUNT = (#const IN_UNMOUNT)++cinotifyEventSize :: CSize+cinotifyEventSize = 16++foreign import ccall unsafe "inotify_init1"+    sysLinuxInotifyInit :: CInotifyFlags -> IO CFd+foreign import ccall unsafe "inotify_add_watch"+    sysLinuxInotifyAddWatch :: CFd -> Ptr CChar -> CInotifyMask -> IO CWatchDescriptor+foreign import ccall unsafe "inotify_rm_watch"+    sysLinuxInotifyRmWatch :: CFd -> CWatchDescriptor -> IO Int

@@ -0,0 +1,19 @@+module Foundation.System.Bindings.Macos+    where++import Foundation.Internal.Base+import Foundation.System.Bindings.PosixDef++#include <sys/mman.h>+#include <sys/stat.h>+#include <unistd.h>+#include <fcntl.h>++sysMacos_O_SHLOCK+    , sysMacos_O_EXLOCK+    , sysMacos_O_SYMLINK+    , sysMacos_O_EVTONLY :: COpenFlags+sysMacos_O_SHLOCK   = (#const O_SHLOCK)+sysMacos_O_EXLOCK   = (#const O_EXLOCK)+sysMacos_O_SYMLINK  = (#const O_SYMLINK)+sysMacos_O_EVTONLY  = (#const O_EVTONLY)

@@ -0,0 +1,345 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Foundation.System.Bindings.Posix+-- Copyright   :  (c) Vincent Hanquez 2014-2017+-- License     :  BSD-style+--+-- Maintainer  :  Vincent Hanquez+-- Stability   :  provisional+-- Portability :  non-portable (requires POSIX)+--+-- Functions defined by the POSIX standards+--+-----------------------------------------------------------------------------++module Foundation.System.Bindings.Posix+   where++import Foundation.Internal.Base+import Foreign.C.Types+import Data.Bits+import Foundation.System.Bindings.PosixDef++#include <sys/mman.h>+#include <sys/stat.h>+#include <unistd.h>+#include <fcntl.h>+#include <errno.h>++data CDir+data CDirent++sysPosix_E2BIG+    , sysPosix_EACCES+    , sysPosix_EADDRINUSE+    , sysPosix_EADDRNOTAVAIL+    , sysPosix_EAFNOSUPPORT+    , sysPosix_EAGAIN+    , sysPosix_EALREADY+    , sysPosix_EBADF+    , sysPosix_EBADMSG+    , sysPosix_EBUSY+    , sysPosix_ECANCELED+    , sysPosix_ECHILD+    , sysPosix_ECONNABORTED+    , sysPosix_ECONNREFUSED+    , sysPosix_ECONNRESET+    , sysPosix_EDEADLK+    , sysPosix_EDESTADDRREQ+    , sysPosix_EDOM+    , sysPosix_EDQUOT+    , sysPosix_EEXIST+    , sysPosix_EFAULT+    , sysPosix_EFBIG+    , sysPosix_EHOSTUNREACH+    , sysPosix_EIDRM+    , sysPosix_EILSEQ+    , sysPosix_EINPROGRESS+    , sysPosix_EINTR+    , sysPosix_EINVAL+    , sysPosix_EIO+    , sysPosix_EISCONN+    , sysPosix_EISDIR+    , sysPosix_ELOOP+    , sysPosix_EMFILE+    , sysPosix_EMLINK+    , sysPosix_EMSGSIZE+    , sysPosix_EMULTIHOP+    , sysPosix_ENAMETOOLONG+    , sysPosix_ENETDOWN+    , sysPosix_ENETRESET+    , sysPosix_ENETUNREACH+    , sysPosix_ENFILE+    , sysPosix_ENOBUFS+    , sysPosix_ENODATA+    , sysPosix_ENODEV+    , sysPosix_ENOENT+    , sysPosix_ENOEXEC+    , sysPosix_ENOLCK+    , sysPosix_ENOLINK+    , sysPosix_ENOMEM+    , sysPosix_ENOMSG+    , sysPosix_ENOPROTOOPT+    , sysPosix_ENOSPC+    , sysPosix_ENOSR+    , sysPosix_ENOSTR+    , sysPosix_ENOSYS+    , sysPosix_ENOTCONN+    , sysPosix_ENOTDIR+    , sysPosix_ENOTEMPTY+    , sysPosix_ENOTRECOVERABLE+    , sysPosix_ENOTSOCK+    , sysPosix_ENOTSUP+    , sysPosix_ENOTTY+    , sysPosix_ENXIO+    , sysPosix_EOPNOTSUPP+    , sysPosix_EOVERFLOW+    , sysPosix_EOWNERDEAD+    , sysPosix_EPERM+    , sysPosix_EPIPE+    , sysPosix_EPROTO+    , sysPosix_EPROTONOSUPPORT+    , sysPosix_EPROTOTYPE+    , sysPosix_ERANGE+    , sysPosix_EROFS+    , sysPosix_ESPIPE+    , sysPosix_ESRCH+    , sysPosix_ESTALE+    , sysPosix_ETIME+    , sysPosix_ETIMEDOUT+    , sysPosix_ETXTBSY+    , sysPosix_EWOULDBLOCK+    , sysPosix_EXDEV :: CErrno+sysPosix_E2BIG = (#const E2BIG)+sysPosix_EACCES = (#const EACCES)+sysPosix_EADDRINUSE = (#const EADDRINUSE)+sysPosix_EADDRNOTAVAIL = (#const EADDRNOTAVAIL)+sysPosix_EAFNOSUPPORT = (#const EAFNOSUPPORT)+sysPosix_EAGAIN = (#const EAGAIN)+sysPosix_EALREADY = (#const EALREADY)+sysPosix_EBADF = (#const EBADF)+sysPosix_EBADMSG = (#const EBADMSG)+sysPosix_EBUSY = (#const EBUSY)+sysPosix_ECANCELED = (#const ECANCELED)+sysPosix_ECHILD = (#const ECHILD)+sysPosix_ECONNABORTED = (#const ECONNABORTED)+sysPosix_ECONNREFUSED = (#const ECONNREFUSED)+sysPosix_ECONNRESET = (#const ECONNRESET)+sysPosix_EDEADLK = (#const EDEADLK)+sysPosix_EDESTADDRREQ = (#const EDESTADDRREQ)+sysPosix_EDOM = (#const EDOM)+sysPosix_EDQUOT = (#const EDQUOT)+sysPosix_EEXIST = (#const EEXIST)+sysPosix_EFAULT = (#const EFAULT)+sysPosix_EFBIG = (#const EFBIG)+sysPosix_EHOSTUNREACH = (#const EHOSTUNREACH)+sysPosix_EIDRM = (#const EIDRM)+sysPosix_EILSEQ = (#const EILSEQ)+sysPosix_EINPROGRESS = (#const EINPROGRESS)+sysPosix_EINTR = (#const EINTR)+sysPosix_EINVAL = (#const EINVAL)+sysPosix_EIO = (#const EIO)+sysPosix_EISCONN = (#const EISCONN)+sysPosix_EISDIR = (#const EISDIR)+sysPosix_ELOOP = (#const ELOOP)+sysPosix_EMFILE = (#const EMFILE)+sysPosix_EMLINK = (#const EMLINK)+sysPosix_EMSGSIZE = (#const EMSGSIZE)+sysPosix_EMULTIHOP = (#const EMULTIHOP)+sysPosix_ENAMETOOLONG = (#const ENAMETOOLONG)+sysPosix_ENETDOWN = (#const ENETDOWN)+sysPosix_ENETRESET = (#const ENETRESET)+sysPosix_ENETUNREACH = (#const ENETUNREACH)+sysPosix_ENFILE = (#const ENFILE)+sysPosix_ENOBUFS = (#const ENOBUFS)+sysPosix_ENODATA = (#const ENODATA)+sysPosix_ENODEV = (#const ENODEV)+sysPosix_ENOENT = (#const ENOENT)+sysPosix_ENOEXEC = (#const ENOEXEC)+sysPosix_ENOLCK = (#const ENOLCK)+sysPosix_ENOLINK = (#const ENOLINK)+sysPosix_ENOMEM = (#const ENOMEM)+sysPosix_ENOMSG = (#const ENOMSG)+sysPosix_ENOPROTOOPT = (#const ENOPROTOOPT)+sysPosix_ENOSPC = (#const ENOSPC)+sysPosix_ENOSR = (#const ENOSR)+sysPosix_ENOSTR = (#const ENOSTR)+sysPosix_ENOSYS = (#const ENOSYS)+sysPosix_ENOTCONN = (#const ENOTCONN)+sysPosix_ENOTDIR = (#const ENOTDIR)+sysPosix_ENOTEMPTY = (#const ENOTEMPTY)+sysPosix_ENOTRECOVERABLE = (#const ENOTRECOVERABLE)+sysPosix_ENOTSOCK = (#const ENOTSOCK)+sysPosix_ENOTSUP = (#const ENOTSUP)+sysPosix_ENOTTY = (#const ENOTTY)+sysPosix_ENXIO = (#const ENXIO)+sysPosix_EOPNOTSUPP = (#const EOPNOTSUPP)+sysPosix_EOVERFLOW = (#const EOVERFLOW)+sysPosix_EOWNERDEAD = (#const EOWNERDEAD)+sysPosix_EPERM = (#const EPERM)+sysPosix_EPIPE = (#const EPIPE)+sysPosix_EPROTO = (#const EPROTO)+sysPosix_EPROTONOSUPPORT = (#const EPROTONOSUPPORT)+sysPosix_EPROTOTYPE = (#const EPROTOTYPE)+sysPosix_ERANGE = (#const ERANGE)+sysPosix_EROFS = (#const EROFS)+sysPosix_ESPIPE = (#const ESPIPE)+sysPosix_ESRCH = (#const ESRCH)+sysPosix_ESTALE = (#const ESTALE)+sysPosix_ETIME = (#const ETIME)+sysPosix_ETIMEDOUT = (#const ETIMEDOUT)+sysPosix_ETXTBSY = (#const ETXTBSY)+sysPosix_EWOULDBLOCK = (#const EWOULDBLOCK)+sysPosix_EXDEV = (#const EXDEV)+++sysPosix_O_RDONLY+    , sysPosix_O_WRONLY+    , sysPosix_O_RDWR+    , sysPosix_O_NONBLOCK+    , sysPosix_O_APPEND+    , sysPosix_O_CREAT+    , sysPosix_O_TRUNC+    , sysPosix_O_EXCL+    , sysPosix_O_NOFOLLOW+    , sysPosix_O_CLOEXEC :: COpenFlags+sysPosix_O_RDONLY   = (#const O_RDONLY)+sysPosix_O_WRONLY   = (#const O_WRONLY)+sysPosix_O_RDWR     = ((#const O_RDONLY) .|. (#const O_WRONLY))+sysPosix_O_NONBLOCK = (#const O_NONBLOCK)+sysPosix_O_APPEND   = (#const O_APPEND)+sysPosix_O_CREAT    = (#const O_CREAT)+sysPosix_O_TRUNC    = (#const O_TRUNC)+sysPosix_O_EXCL     = (#const O_EXCL)+sysPosix_O_NOFOLLOW = (#const O_NOFOLLOW)+sysPosix_O_CLOEXEC  = (#const O_CLOEXEC)++sysPosix_PROT_NONE+    , sysPosix_PROT_READ+    , sysPosix_PROT_WRITE+    , sysPosix_PROT_EXEC :: CMemProtFlags+sysPosix_PROT_NONE  = (#const PROT_NONE)+sysPosix_PROT_READ  = (#const PROT_READ)+sysPosix_PROT_WRITE = (#const PROT_WRITE)+sysPosix_PROT_EXEC  = (#const PROT_EXEC)++sysPosix_MAP_SHARED+    , sysPosix_MAP_PRIVATE+    , sysPosix_MAP_FIXED+    , sysPosix_MAP_ANONYMOUS :: CMemMappingFlags+sysPosix_MAP_SHARED    = (#const MAP_SHARED)+sysPosix_MAP_PRIVATE   = (#const MAP_PRIVATE)+sysPosix_MAP_FIXED     = (#const MAP_FIXED)+#ifdef __APPLE__+sysPosix_MAP_ANONYMOUS = (#const MAP_ANON)+#else+sysPosix_MAP_ANONYMOUS = (#const MAP_ANONYMOUS)+#endif++sysPosix_MADV_NORMAL+    , sysPosix_MADV_RANDOM+    , sysPosix_MADV_SEQUENTIAL+    , sysPosix_MADV_WILLNEED+    , sysPosix_MADV_DONTNEED :: CMemAdvice+#if defined(POSIX_MADV_NORMAL)+sysPosix_MADV_NORMAL     = (#const POSIX_MADV_NORMAL)+sysPosix_MADV_RANDOM     = (#const POSIX_MADV_RANDOM)+sysPosix_MADV_SEQUENTIAL = (#const POSIX_MADV_SEQUENTIAL)+sysPosix_MADV_WILLNEED   = (#const POSIX_MADV_WILLNEED)+sysPosix_MADV_DONTNEED   = (#const POSIX_MADV_DONTNEED)+#else+sysPosix_MADV_NORMAL     = (#const MADV_NORMAL)+sysPosix_MADV_RANDOM     = (#const MADV_RANDOM)+sysPosix_MADV_SEQUENTIAL = (#const MADV_SEQUENTIAL)+sysPosix_MADV_WILLNEED   = (#const MADV_WILLNEED)+sysPosix_MADV_DONTNEED   = (#const MADV_DONTNEED)+#endif++sysPosix_MS_ASYNC+    , sysPosix_MS_SYNC+    , sysPosix_MS_INVALIDATE :: CMemSyncFlags+sysPosix_MS_ASYNC      = (#const MS_ASYNC)+sysPosix_MS_SYNC       = (#const MS_SYNC)+sysPosix_MS_INVALIDATE = (#const MS_INVALIDATE)++foreign import ccall unsafe "mmap"+    sysPosixMmap :: Ptr a -> CSize -> CMemProtFlags -> CMemMappingFlags -> CFd -> COff -> IO (Ptr a)++foreign import ccall unsafe "munmap"+    sysPosixMunmap :: Ptr a -> CSize -> IO CInt++#if defined(POSIX_MADV_NORMAL)+foreign import ccall unsafe "posix_madvise"+    sysPosixMadvise :: Ptr a -> CSize -> CMemAdvice -> IO CInt+#else+foreign import ccall unsafe "madvise"+    sysPosixMadvise :: Ptr a -> CSize -> CMemAdvice -> IO CInt+#endif++foreign import ccall unsafe "msync"+    sysPosixMsync :: Ptr a -> CSize -> CMemSyncFlags -> IO CInt++foreign import ccall unsafe "mprotect"+    sysPosixMprotect :: Ptr a -> CSize -> CMemProtFlags -> IO CInt++#ifndef __HAIKU__+foreign import ccall unsafe "mlock"+    sysPosixMlock :: Ptr a -> CSize -> IO CInt+#else+sysPosixMlock :: Ptr a -> CSize -> IO CInt+sysPosixMlock _ _ = return (-1)+#endif++#ifndef __HAIKU__+foreign import ccall unsafe "munlock"+    sysPosixMunlock :: Ptr a -> CSize -> IO CInt+#else+sysPosixMunlock :: Ptr a -> CSize -> IO CInt+sysPosixMunlock _ _ = return (-1)+#endif++sysPosix_SC_PAGESIZE :: CSysconfName+sysPosix_SC_PAGESIZE = (#const _SC_PAGESIZE)++foreign import ccall unsafe "sysconf"+    sysPosixSysconf :: CSysconfName -> CLong+--------------------------------------------------------------------------------+-- files+--------------------------------------------------------------------------------+foreign import ccall unsafe "open"+    sysPosixOpen :: Ptr CChar -> COpenFlags -> CMode -> IO CFd+foreign import ccall unsafe "openat"+    sysPosixOpenAt :: CFd -> Ptr CChar -> COpenFlags -> CMode -> IO CFd+foreign import ccall unsafe "close"+    sysPosixClose :: CFd -> IO CInt++foreign import ccall unsafe "fcntl"+    sysPosixFnctlNoArg :: CFd -> CInt -> IO CInt+foreign import ccall unsafe "fcntl"+    sysPosixFnctlPtr :: CFd -> CInt -> Ptr a -> IO CInt++foreign import ccall unsafe "ftruncate"+    sysPosixFtruncate :: CFd -> COff -> IO CInt++--------------------------------------------------------------------------------+-- directories+--------------------------------------------------------------------------------++foreign import ccall unsafe "opendir"+    sysPosixOpendir :: Ptr CChar -> IO (Ptr CDir)+foreign import ccall unsafe "fdopendir"+    sysPosixFdopendir :: CFd -> IO (Ptr CDir)+foreign import ccall unsafe "readdir"+    sysPosixReaddir :: Ptr CDir -> IO (Ptr CDirent)+foreign import ccall unsafe "readdir_r"+    sysPosixReaddirR :: Ptr CDir -> Ptr CDirent -> Ptr (Ptr CDirent) -> IO CInt+foreign import ccall unsafe "telldir"+    sysPosixTelldir :: Ptr CDir -> IO CLong+foreign import ccall unsafe "seekdir"+    sysPosixSeekdir :: Ptr CDir -> CLong -> IO ()+foreign import ccall unsafe "rewinddir"+    sysPosixRewinddir :: Ptr CDir -> IO ()+foreign import ccall unsafe "closedir"+    sysPosixClosedir :: Ptr CDir -> IO CInt+foreign import ccall unsafe "dirfd"+    sysPosixDirfd :: Ptr CDir -> IO CFd

@@ -0,0 +1,25 @@++module Foundation.System.Bindings.PosixDef+    ( CErrno+    , CFd+    , CMemProtFlags+    , CMemMappingFlags+    , CMemAdvice+    , CMemSyncFlags+    , CSysconfName+    , COpenFlags+    , COff(..)+    , CMode(..)+    ) where++import Foreign.C.Types+import System.Posix.Types (COff(..), CMode(..))++type CErrno = CInt+type CFd = CInt+type CMemProtFlags = CInt+type CMemMappingFlags = CInt+type CMemAdvice = CInt+type CMemSyncFlags = CInt+type CSysconfName = CInt+type COpenFlags = CInt

@@ -0,0 +1,2 @@+module Foundation.System.Bindings.Windows+     where

@@ -1,5 +1,5 @@ Name:                foundation-Version:             0.0.3+Version:             0.0.4 Synopsis:            Alternative prelude with batteries and no dependencies Description:     A custom prelude with no dependencies apart from base.@@ -56,6 +56,7 @@                      Foundation.Bits                      Foundation.Class.Bifunctor                      Foundation.Class.Storable+                     Foundation.Conduit                      Foundation.Convertible                      Foundation.String                      Foundation.String.ASCII@@ -73,12 +74,17 @@                      Foundation.Monad                      Foundation.Monad.Reader                      Foundation.Monad.State+                     Foundation.Network.IPv4+                     Foundation.Network.IPv6                      Foundation.System.Info                      Foundation.Strict                      Foundation.Parser                      Foundation.Random                      Foundation.System.Entropy-  Other-modules:     Foundation.String.Internal+                     Foundation.System.Bindings+  Other-modules:     Foundation.Boot.Builder+                     Foundation.Boot.List+                     Foundation.String.Internal                      Foundation.String.UTF8                      Foundation.String.Encoding.Encoding                      Foundation.String.Encoding.UTF16@@ -97,15 +103,19 @@                      Foundation.Collection.Element                      Foundation.Collection.InnerFunctor                      Foundation.Collection.Collection+                     Foundation.Collection.Copy                      Foundation.Collection.Sequential                      Foundation.Collection.Keyed                      Foundation.Collection.Indexed                      Foundation.Collection.Foldable                      Foundation.Collection.Mutable                      Foundation.Collection.Zippable+                     Foundation.Conduit.Internal                      Foundation.Internal.Base+                     Foundation.Internal.ByteSwap                      Foundation.Internal.CallStack                      Foundation.Internal.Environment+                     Foundation.Internal.Error                      Foundation.Internal.Primitive                      Foundation.Internal.IsList                      Foundation.Internal.Identity@@ -123,6 +133,8 @@                      Foundation.Numerical.Floating                      Foundation.IO.File                      Foundation.IO.Terminal+                     Foundation.Primitive.Base16+                     Foundation.Primitive.Endianness                      Foundation.Primitive.Types                      Foundation.Primitive.Monad                      Foundation.Primitive.Utils@@ -148,11 +160,19 @@   C-sources:         cbits/foundation_random.c    if os(windows)+    Exposed-modules: Foundation.System.Bindings.Windows     Other-modules:   Foundation.Foreign.MemoryMap.Windows                      Foundation.System.Entropy.Windows   else+    Exposed-modules: Foundation.System.Bindings.Posix+                     Foundation.System.Bindings.PosixDef+                     Foundation.System.Bindings.Hs     Other-modules:   Foundation.Foreign.MemoryMap.Posix                      Foundation.System.Entropy.Unix+  if os(linux)+    Exposed-modules: Foundation.System.Bindings.Linux+  if os(osx)+    Exposed-modules: Foundation.System.Bindings.Macos    if impl(ghc >= 7.10)     Exposed-modules: Foundation.Tuple.Nth@@ -187,11 +207,15 @@   Main-is:           Tests.hs   Other-modules:     Test.Utils.Foreign                      Test.Data.List+                     Test.Data.Network                      Test.Data.Unicode                      Test.Data.ASCII                      Test.Foundation.Collection+                     Test.Foundation.Conduit                      Test.Foundation.Bits                      Test.Foundation.ChunkedUArray+                     Test.Foundation.Network.IPv4+                     Test.Foundation.Network.IPv6                      Test.Foundation.Number                      Test.Foundation.Encoding                      Test.Foundation.Parser@@ -199,6 +223,7 @@                      Test.Foundation.String                      Test.Foundation.Storable                      Test.Foundation.Random+                     Test.Foundation.Misc                      Imports   Default-Extensions: NoImplicitPrelude                       RebindableSyntax

@@ -0,0 +1,74 @@+-- |+-- Module:+-- Author: Nicolas Di Prima <nicolas>+-- Date:   2017-01-18T17:34:06+00:00+-- Email:  nicolasdiprima@gmail.com+--++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}++module Test.Data.Network+    ( genIPv4+    , genIPv4Tuple+    , genIPv4String+    , genIPv6+    , genIPv6Tuple+    , genIPv6String+    ) where++import Foundation+import Foundation.Network.IPv4 as IPv4+import Foundation.Network.IPv6 as IPv6+import Foundation.Class.Storable as F+import Test.Tasty.QuickCheck+import qualified Foreign.Storable as Foreign++instance Arbitrary IPv4 where+    arbitrary = genIPv4+instance Foreign.Storable IPv4 where+    sizeOf a = let Size b = F.size (Just a) in b+    alignment a = let Size b = F.alignment (Just a) in b+    peek = F.peek+    poke = F.poke+instance Arbitrary IPv6 where+    arbitrary = genIPv6+instance Foreign.Storable IPv6 where+    sizeOf a = let Size b = F.size (Just a) in b+    alignment a = let Size b = F.alignment (Just a) in b+    peek = F.peek+    poke = F.poke++genIPv4Tuple :: Gen (Word8, Word8, Word8, Word8)+genIPv4Tuple =+    (,,,) <$> choose (0, 255)+          <*> choose (0, 255)+          <*> choose (0, 255)+          <*> choose (0, 255)++genIPv6Tuple :: Gen (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)+genIPv6Tuple =+    (,,,,,,,) <$> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary+              <*> arbitrary++genIPv4String :: Gen String+genIPv4String = do+    (w1, w2, w3, w4) <- genIPv4Tuple+    return $ show w1 <> "." <> show w2 <> "." <> show w3 <> "." <> show w4++genIPv6String :: Gen String+genIPv6String = IPv6.toString <$> genIPv6++genIPv6 :: Gen IPv6+genIPv6 = IPv6.fromTuple <$> genIPv6Tuple++-- | a better generator for unicode Character+genIPv4 :: Gen IPv4+genIPv4 = IPv4.fromTuple <$> genIPv4Tuple

@@ -11,6 +11,8 @@ import Foundation import Foundation.Collection import Foundation.Foreign+import Foundation.Primitive+import Foundation.Class.Storable  import Test.Tasty import Test.Tasty.QuickCheck@@ -35,6 +37,12 @@         , testCollection "UArray(F64)" (Proxy :: Proxy (UArray Double)) arbitrary         , testCollection "UArray(CChar)"  (Proxy :: Proxy (UArray CChar))  (CChar <$> arbitrary)         , testCollection "UArray(CUChar)" (Proxy :: Proxy (UArray CUChar)) (CUChar <$> arbitrary)+        , testCollection "UArray(BE W16)" (Proxy :: Proxy (UArray (BE Word16))) (toBE <$> arbitrary)+        , testCollection "UArray(BE W32)" (Proxy :: Proxy (UArray (BE Word32))) (toBE <$> arbitrary)+        , testCollection "UArray(BE W64)" (Proxy :: Proxy (UArray (BE Word64))) (toBE <$> arbitrary)+        , testCollection "UArray(LE W16)" (Proxy :: Proxy (UArray (LE Word16))) (toLE <$> arbitrary)+        , testCollection "UArray(LE W32)" (Proxy :: Proxy (UArray (LE Word32))) (toLE <$> arbitrary)+        , testCollection "UArray(LE W64)" (Proxy :: Proxy (UArray (LE Word64))) (toLE <$> arbitrary)         ]     , testGroup "Unboxed-Foreign"         [ testGroup "UArray(W8)"  (testUnboxedForeign (Proxy :: Proxy (UArray Word8))  arbitrary)@@ -49,6 +57,12 @@         , testGroup "UArray(F64)" (testUnboxedForeign (Proxy :: Proxy (UArray Double)) arbitrary)         , testGroup "UArray(CChar)"  (testUnboxedForeign (Proxy :: Proxy (UArray CChar))  (CChar <$> arbitrary))         , testGroup "UArray(CUChar)" (testUnboxedForeign (Proxy :: Proxy (UArray CUChar)) (CUChar <$> arbitrary))+        , testGroup "UArray(BE W16)" (testUnboxedForeign (Proxy :: Proxy (UArray (BE Word16))) (toBE <$> arbitrary))+        , testGroup "UArray(BE W32)" (testUnboxedForeign (Proxy :: Proxy (UArray (BE Word32))) (toBE <$> arbitrary))+        , testGroup "UArray(BE W64)" (testUnboxedForeign (Proxy :: Proxy (UArray (BE Word64))) (toBE <$> arbitrary))+        , testGroup "UArray(LE W16)" (testUnboxedForeign (Proxy :: Proxy (UArray (LE Word16))) (toLE <$> arbitrary))+        , testGroup "UArray(LE W32)" (testUnboxedForeign (Proxy :: Proxy (UArray (LE Word32))) (toLE <$> arbitrary))+        , testGroup "UArray(LE W64)" (testUnboxedForeign (Proxy :: Proxy (UArray (LE Word64))) (toLE <$> arbitrary))         ]     , testGroup "Boxed"         [ testCollection "Array(W8)"  (Proxy :: Proxy (Array Word8))  arbitrary@@ -66,10 +80,16 @@         , testCollection "Array(Integer)" (Proxy :: Proxy (Array Integer)) arbitrary         , testCollection "Array(CChar)"   (Proxy :: Proxy (Array CChar))  (CChar <$> arbitrary)         , testCollection "Array(CUChar)"  (Proxy :: Proxy (Array CUChar)) (CUChar <$> arbitrary)+        , testCollection "Array(BE W16)"  (Proxy :: Proxy (Array (BE Word16))) (toBE <$> arbitrary)+        , testCollection "Array(BE W32)"  (Proxy :: Proxy (Array (BE Word32))) (toBE <$> arbitrary)+        , testCollection "Array(BE W64)"  (Proxy :: Proxy (Array (BE Word64))) (toBE <$> arbitrary)+        , testCollection "Array(LE W16)"  (Proxy :: Proxy (Array (LE Word16))) (toLE <$> arbitrary)+        , testCollection "Array(LE W32)"  (Proxy :: Proxy (Array (LE Word32))) (toLE <$> arbitrary)+        , testCollection "Array(LE W64)"  (Proxy :: Proxy (Array (LE Word64))) (toLE <$> arbitrary)         ]     ] -testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, Storable e)+testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, StorableFixed e)                    => Proxy a -> Gen e -> [TestTree] testUnboxedForeign proxy genElement =     [ testProperty "equal" $ withElementsM $ \fptr l ->

@@ -6,7 +6,6 @@ import Foundation.Bits import Imports import Foundation-import Foundation.Numerical  tests = testGroup "Bits"     [ testProperty "round-up" $ \(Positive m) n' -> n' >= 1 ==>

@@ -12,6 +12,8 @@ import Foundation.Collection import Foundation.Array import Foundation.Foreign+import Foundation.Class.Storable+import Foundation.Primitive  import Test.Tasty import Test.Tasty.QuickCheck@@ -34,6 +36,12 @@         , testCollection "ChunkedUArray(I64)" (Proxy :: Proxy (ChunkedUArray Int64))  arbitrary         , testCollection "ChunkedUArray(F32)" (Proxy :: Proxy (ChunkedUArray Float))  arbitrary         , testCollection "ChunkedUArray(F64)" (Proxy :: Proxy (ChunkedUArray Double)) arbitrary+        , testCollection "ChunkedUArray(BE W16)" (Proxy :: Proxy (ChunkedUArray (BE Word16))) (toBE <$> arbitrary)+        , testCollection "ChunkedUArray(BE W32)" (Proxy :: Proxy (ChunkedUArray (BE Word32))) (toBE <$> arbitrary)+        , testCollection "ChunkedUArray(BE W64)" (Proxy :: Proxy (ChunkedUArray (BE Word64))) (toBE <$> arbitrary)+        , testCollection "ChunkedUArray(LE W16)" (Proxy :: Proxy (ChunkedUArray (LE Word16))) (toLE <$> arbitrary)+        , testCollection "ChunkedUArray(LE W32)" (Proxy :: Proxy (ChunkedUArray (LE Word32))) (toLE <$> arbitrary)+        , testCollection "ChunkedUArray(LE W64)" (Proxy :: Proxy (ChunkedUArray (LE Word64))) (toLE <$> arbitrary)         ]     , testGroup "Unboxed-Foreign"         [ testGroup "UArray(W8)"  (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word8))  arbitrary)@@ -46,6 +54,12 @@         , testGroup "UArray(I64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Int64))  arbitrary)         , testGroup "UArray(F32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Float))  arbitrary)         , testGroup "UArray(F64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Double)) arbitrary)+        , testGroup "UArray(BE W16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (BE Word16))) (toBE <$> arbitrary))+        , testGroup "UArray(BE W32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (BE Word32))) (toBE <$> arbitrary))+        , testGroup "UArray(BE W64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (BE Word64))) (toBE <$> arbitrary))+        , testGroup "UArray(LE W16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (LE Word16))) (toLE <$> arbitrary))+        , testGroup "UArray(LE W32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (LE Word32))) (toLE <$> arbitrary))+        , testGroup "UArray(LE W64)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray (LE Word64))) (toLE <$> arbitrary))         ]     , testGroup "Boxed"         [ testCollection "Array(W8)"  (Proxy :: Proxy (Array Word8))  arbitrary@@ -61,10 +75,16 @@         , testCollection "Array(Int)" (Proxy :: Proxy (Array Int))  arbitrary         , testCollection "Array(Int,Int)" (Proxy :: Proxy (Array (Int,Int)))  arbitrary         , testCollection "Array(Integer)" (Proxy :: Proxy (Array Integer)) arbitrary+        , testCollection "Array(BE W16)" (Proxy :: Proxy (Array (BE Word16))) (toBE <$> arbitrary)+        , testCollection "Array(BE W32)" (Proxy :: Proxy (Array (BE Word32))) (toBE <$> arbitrary)+        , testCollection "Array(BE W64)" (Proxy :: Proxy (Array (BE Word64))) (toBE <$> arbitrary)+        , testCollection "Array(LE W16)" (Proxy :: Proxy (Array (LE Word16))) (toLE <$> arbitrary)+        , testCollection "Array(LE W32)" (Proxy :: Proxy (Array (LE Word32))) (toLE <$> arbitrary)+        , testCollection "Array(LE W64)" (Proxy :: Proxy (Array (LE Word64))) (toLE <$> arbitrary)         ]     ] -testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, Storable e)+testUnboxedForeign :: (PrimType e, Show e, Element a ~ e, StorableFixed e)                    => Proxy a -> Gen e -> [TestTree] testUnboxedForeign proxy genElement =     [ testProperty "equal" $ withElementsM $ \fptr l ->

@@ -152,6 +152,12 @@     , testProperty "notElem" $ withListAndElement $ \(l,e) -> notElem e (fromListP proxy l) == notElem e l     , testProperty "minimum" $ withNonEmptyElements $ \els -> minimum (fromListNonEmptyP proxy els) === minimum els     , testProperty "maximum" $ withNonEmptyElements $ \els -> maximum (fromListNonEmptyP proxy els) === maximum els+    , testProperty "all" $ withListAndElement $ \(l, e) ->+        all (/= e) (fromListP proxy l) == all (/= e) l &&+        all (== e) (fromListP proxy l) == all (== e) l+    , testProperty "any" $ withListAndElement $ \(l, e) ->+        any (/= e) (fromListP proxy l) == any (/= e) l &&+        any (== e) (fromListP proxy l) == any (== e) l     ]   where     withElements f = forAll (generateListOfElement genElement) f

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Test.Foundation.Conduit+  ( testConduit+  ) where++import Foundation+import Foundation.Conduit+import Foundation.IO++import Imports++testConduit :: TestTree+testConduit = testGroup "Conduit"+    [ testCase "sourceHandle gives same data as readFile" testSourceFile+    , testCase "sourceHandle/sinkHandle copies data" testCopyFile+    , testCase "sourceFile/sinkFile copies data" testCopyFileRes+    ]+  where+    testSourceFile :: Assertion+    testSourceFile = do+        let fp = "foundation.cabal"+        arrs <- withFile fp ReadMode+            $ \h -> runConduit $ sourceHandle h .| sinkList+        arr <- readFile fp+        assertEqual "foundation.cabal contents" arr (mconcat arrs)++    testCopyFile :: Assertion+    testCopyFile = do+        let src = "foundation.cabal"+            dst = "temp-file" -- FIXME some temp file API?+        withFile src ReadMode $ \hin -> withFile dst WriteMode $ \hout ->+            runConduit $ sourceHandle hin .| sinkHandle hout+        orig <- readFile src+        new <- readFile dst+        assertEqual "copied foundation.cabal contents" orig new++    testCopyFileRes :: Assertion+    testCopyFileRes = do+        let src = "foundation.cabal"+            dst = "temp-file" -- FIXME some temp file API?+        runConduitRes $ sourceFile src .| sinkFile dst+        orig <- readFile src+        new <- readFile dst+        assertEqual "copied foundation.cabal contents" orig new

@@ -0,0 +1,28 @@+module Test.Foundation.Misc+    ( testHexadecimal+    ) where++import Foundation+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.QuickCheck.Monadic++import Foundation.Array.Internal (toHexadecimal)+import Test.Foundation.Collection (fromListP, toListP)++hex :: [Word8] -> [Word8]+hex = loop+  where+    toHex :: Int -> Word8+    toHex n+        | n < 10   = fromIntegral (n + fromEnum '0')+        | otherwise = fromIntegral (n - 10 + fromEnum 'a')+    loop []     = []+    loop (x:xs) = toHex (fromIntegral q):toHex (fromIntegral r):loop xs+      where+        (q,r) = x `divMod` 16++testHexadecimal = testGroup "hexadecimal"+    [ testProperty  "UArray(W8)" $ \l -> +        toList (toHexadecimal (fromListP (Proxy :: Proxy (UArray Word8)) l)) == hex l+    ]

@@ -0,0 +1,40 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Foundation.Network.IPv4+    ( testNetworkIPv4+    ) where++import Foundation+import Foundation.Network.IPv4++import Test.Tasty+import Test.Tasty.QuickCheck++import Test.Data.Network+import Test.Foundation.Storable++-- | test property equality for the given Collection+testEquality :: Gen IPv4 -> TestTree+testEquality genElement = testGroup "equality"+    [ testProperty "x == x" $ forAll genElement (\x -> x === x)+    , testProperty "x == y" $ forAll ((,) <$> genElement <*> genElement) $+        \(x,y) -> (toTuple x == toTuple y) === (x == y)+    ]++-- | test ordering+testOrdering :: Gen IPv4 -> TestTree+testOrdering genElement = testProperty "ordering" $+    forAll ((,) <$> genElement <*> genElement) $ \(x, y) ->+        (toTuple x `compare` toTuple y) === x `compare` y++testNetworkIPv4 :: TestTree+testNetworkIPv4 = testGroup "IPv4"+    [ testProperty "toTuple . fromTuple == id" $+        forAll genIPv4Tuple $ \x -> x === toTuple (fromTuple x)+    , testProperty "toString . fromString == id" $+        forAll genIPv4String $ \x -> x === toString (fromString $ toList x)+    , testEquality genIPv4+    , testOrdering genIPv4+    , testPropertyStorable      "Storable" (Proxy :: Proxy IPv4)+    , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv4)+    ]

@@ -0,0 +1,55 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Foundation.Network.IPv6+    ( testNetworkIPv6+    ) where++import Foundation+import Foundation.Network.IPv6++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit++import Test.Data.Network+import Test.Foundation.Storable++-- | test property equality for the given Collection+testEquality :: Gen IPv6 -> TestTree+testEquality genElement = testGroup "equality"+    [ testProperty "x == x" $ forAll genElement (\x -> x === x)+    , testProperty "x == y" $ forAll ((,) <$> genElement <*> genElement) $+        \(x,y) -> (toTuple x == toTuple y) === (x == y)+    ]++-- | test ordering+testOrdering :: Gen IPv6 -> TestTree+testOrdering genElement = testProperty "ordering" $+    forAll ((,) <$> genElement <*> genElement) $ \(x, y) ->+        (toTuple x `compare` toTuple y) === x `compare` y++testNetworkIPv6 :: TestTree+testNetworkIPv6 = testGroup "IPv6"+    [ testProperty "toTuple . fromTuple == id" $+        forAll genIPv6Tuple $ \x -> x === toTuple (fromTuple x)+    , testProperty "toString . fromString == id" $+        forAll genIPv6String $ \x -> x === toString (fromString $ toList x)+    , testEquality genIPv6+    , testOrdering genIPv6+    , testPropertyStorable      "Storable" (Proxy :: Proxy IPv6)+    , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv6)+    , testGroup "parse"+        [ testCase "::"  $ assert $ fromTuple (0,0,0,0,0,0,0,0) == fromString "::"+        , testCase "::1" $ assert $ fromTuple (0,0,0,0,0,0,0,1) == fromString "::1"+        , testCase "2001:DB8::8:800:200C:417A" $ assert $ fromTuple (0x2001,0xDB8,0,0,0x8,0x800,0x200c,0x417a) == fromString "2001:DB8::8:800:200C:417A"+        , testCase "FF01::101" $ assert $ fromTuple (0xff01,0,0,0,0,0,0,0x101) == fromString "FF01::101"+        , testCase "::13.1.68.3" $ assertEq (fromTuple (0,0,0,0,0,0,0x0d01,0x4403)) (fromString "::13.1.68.3")+        , testCase "::FFFF:129.144.52.38" $ assertEq (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) (fromString "::FFFF:129.144.52.38")+        , testCase "0::FFFF:129.144.52.38" $ assertEq (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) (fromString "0::FFFF:129.144.52.38")+        , testCase "0:0::FFFF:129.144.52.38" $ assertEq (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) (fromString "0:0::FFFF:129.144.52.38")+        ]+    ]++assertEq a b+    | a /= b = error $ show a <> " /= " <> show b+    | otherwise = return ()

@@ -6,7 +6,8 @@   ) where  import Foundation-import Foundation.Parser+import           Foundation.Parser+import qualified Foundation.Parser as P  import Test.Tasty import Test.Tasty.HUnit@@ -58,10 +59,10 @@         , testCase "MoreFail" $ parseTestCase ""    anyElement $ TestCaseMore Nothing TestCaseFail         ]     , testGroup "take"-        [ testCase "OK" $ parseTestCase "a" (take 1) (TestCaseOk "" "a")-        , testCase "OkRemains" $ parseTestCase "abc" (take 2) (TestCaseOk "c" "ab")-        , testCase "MoreOk" $ parseTestCase "" (take 2) $ TestCaseMore (Just "abc")(TestCaseOk "c" "ab")-        , testCase "MoreFail" $ parseTestCase "a" (take 2) $ TestCaseMore Nothing TestCaseFail+        [ 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         ]     , testGroup "takeWhile"         [ testCase "OK" $ parseTestCase "a " (takeWhile (' ' /=)) (TestCaseOk " " "a")

@@ -5,10 +5,12 @@ {-# LANGUAGE TypeFamilies        #-} module Test.Foundation.Storable     ( testForeignStorableRefs+    , testPropertyStorable, testPropertyStorableFixed     ) where  import Foundation import Foundation.Class.Storable+import Foundation.Primitive  import qualified Foreign.Storable import qualified Foreign.Marshal.Alloc@@ -46,8 +48,28 @@         , testPropertyStorableFixed "Double" (Proxy :: Proxy Double)         , testPropertyStorableFixed "Float" (Proxy :: Proxy Float)         ]+    , testGroup "Endianness"+        [ testPropertyBE "Word16" (Proxy :: Proxy Word16)+        , testPropertyBE "Word32" (Proxy :: Proxy Word32)+        , testPropertyBE "Word64" (Proxy :: Proxy Word64)+        ]     ] +testPropertyBE :: (ByteSwap a, StorableFixed a, Arbitrary a, Eq a, Show a)+               => LString+               -> Proxy a+               -> TestTree+testPropertyBE name p = testGroup name+    [ testProperty "fromBE . toBE == id" $ withProxy p $ \a ->+        fromBE (toBE a) === a+    , testProperty "fromLE . toLE == id" $ withProxy p $ \a ->+        fromLE (toLE a) === a+    ]+  where+    withProxy :: (ByteSwap a, StorableFixed a, Arbitrary a, Show a, Eq a)+              => Proxy a -> (a -> Property) -> (a -> Property)+    withProxy _ f = f+ testPropertyStorable :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a)                      => LString                      -> Proxy a@@ -80,7 +102,7 @@     v' <- run $ Foreign.Marshal.Alloc.alloca $ \ptr -> do             Foreign.Storable.poke ptr v             peek ptr-    assert $ v == v'+    assertEq v v'  testPropertyStorablePoke :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a)                          => Proxy a@@ -90,7 +112,13 @@     v' <- run $ Foreign.Marshal.Alloc.alloca $ \ptr -> do             poke ptr v             Foreign.Storable.peek ptr-    assert $ v == v'+    assertEq v v'++assertEq a b+  | a == b = assert True+  | otherwise = do+      run $ putStrLn $ show a <> " /= " <> show b+      assert False  data SomeWhereInArray a = SomeWhereInArray a Int Int     deriving (Show, Eq)

@@ -1,3 +1,5 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-} module Test.Utils.Foreign     ( Ptr     , Storable@@ -8,19 +10,19 @@ import           Foreign.Marshal.Alloc  import           Foreign.Ptr-import           Foreign.Storable import           Foundation-import           Prelude (head, zip)+import           Prelude (zip) import           Control.Monad (forM_)  import           Foundation.Foreign+import           Foundation.Class.Storable -createPtr :: Storable e => [e] -> IO (FinalPtr e)+createPtr :: forall e . StorableFixed e => [e] -> IO (FinalPtr e) createPtr l     | null l    = toFinalPtr nullPtr (\_ -> return ())     | otherwise = do-        let szElem = sizeOf (head l)+        let (Size szElem) = size (Proxy :: Proxy e)             nbBytes = szElem * length l         ptr <- mallocBytes nbBytes-        forM_ (zip [0..] l) $ \(o, e) -> pokeElemOff ptr o e+        forM_ (zip [0..] l) $ \(o, e) -> pokeOff ptr o e         toFinalPtr ptr (\p -> free p)

@@ -20,6 +20,7 @@ import Test.Data.List  import Test.Foundation.Collection+import Test.Foundation.Conduit import Test.Foundation.Number import Test.Foundation.Array import Test.Foundation.ChunkedUArray@@ -27,6 +28,9 @@ import Test.Foundation.Parser import Test.Foundation.Storable import Test.Foundation.Random+import Test.Foundation.Network.IPv4+import Test.Foundation.Network.IPv6+import Test.Foundation.Misc import qualified Test.Foundation.Bits as Bits  data CharMap = CharMap LUString Prelude.Int@@ -73,7 +77,7 @@ assertEq :: (Eq a, Show a) => a -> a -> Bool assertEq got expected     | got == expected = True-    | otherwise       = error $ toList ("got: " <> show got <> " expected: " <> show expected)+    | otherwise       = error ("got: " <> show got <> " expected: " <> show expected)  -- | Set in front of tests to make them verbose qcv :: TestTree -> TestTree@@ -317,6 +321,10 @@     , testParsers     , testForeignStorableRefs     , testRandom+    , testConduit+    , testNetworkIPv4+    , testNetworkIPv6+    , testHexadecimal     ]  testCaseModifiedUTF8 :: [Char] -> String -> Assertion