foundation 0.0.7 → 0.0.8

raw patch · 38 files changed

+1133/−217 lines, 38 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Foundation.hs +4/−0
• Foundation/Array/Boxed.hs +9/−1
• Foundation/Array/Chunked/Unboxed.hs +3/−0
• Foundation/Array/Internal.hs +5/−0
• Foundation/Array/Unboxed.hs +13/−2
• Foundation/Array/Unboxed/Mutable.hs +2/−2
• Foundation/Check.hs +3/−1
• Foundation/Check/Arbitrary.hs +5/−1
• Foundation/Conduit.hs +1/−0
• Foundation/Conduit/Internal.hs +6/−0
• Foundation/Conduit/Textual.hs +52/−0
• Foundation/IO.hs +2/−0
• Foundation/IO/Terminal.hs +3/−0
• Foundation/Internal/NumLiteral.hs +4/−2
• Foundation/List/DList.hs +88/−0
• Foundation/Monad/Reader.hs +12/−1
• Foundation/Monad/State.hs +22/−2
• Foundation/Network/IPv4.hs +3/−1
• Foundation/Network/IPv6.hs +3/−1
• Foundation/Primitive.hs +6/−0
• Foundation/Primitive/Floating.hs +8/−0
• Foundation/Primitive/NormalForm.hs +116/−0
• Foundation/String/Read.hs +2/−0
• Foundation/String/UTF8.hs +236/−93
• Foundation/System/Bindings/Linux.hsc +7/−2
• Foundation/System/Bindings/Posix.hsc +9/−3
• Foundation/Tuple.hs +10/−0
• Foundation/UUID.hs +2/−0
• README.md +1/−1
• benchs/Fake/ByteString.hs +8/−1
• benchs/Fake/Text.hs +9/−1
• benchs/Main.hs +51/−0
• cbits/foundation_random.c +1/−0
• foundation.cabal +36/−12
• tests/Checks.hs +89/−6
• tests/Test/Checks/Property/Collection.hs +300/−0
• tests/Test/Foundation/Array.hs +1/−44
• tests/Test/Foundation/ChunkedUArray.hs +1/−40

@@ -39,6 +39,9 @@     , Prelude.asTypeOf     , Prelude.undefined     , Prelude.seq+    , Foundation.Primitive.NormalForm+    , Foundation.Primitive.deepseq+    , Foundation.Primitive.force       -- ** Type classes     , Prelude.Show     , show@@ -169,6 +172,7 @@  import qualified Foundation.Class.Bifunctor import           Foundation.Primitive.Types.OffsetSize (Size(..), Offset(..))+import qualified Foundation.Primitive import           Foundation.Internal.NumLiteral import           Foundation.Internal.Natural 

@@ -20,7 +20,6 @@     , mutableLength     , mutableLengthSize     , copy-    , copyAt     , unsafeCopyAtRO     , thaw     , new@@ -72,6 +71,7 @@ import           Foundation.Internal.MonadTrans import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Types+import           Foundation.Primitive.NormalForm import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Monad import           Foundation.Array.Common@@ -92,6 +92,14 @@  arrayType :: DataType arrayType = mkNoRepType "Foundation.Array"++instance NormalForm a => NormalForm (Array a) where+    toNormalForm arr = loop 0+      where+        !sz = lengthSize arr+        loop !i+            | i .==# sz = ()+            | otherwise = unsafeIndex arr i `seq` loop (i+1)  -- | Mutable Array of a data MArray a st = MArray {-# UNPACK #-} !(Offset a)

@@ -30,6 +30,7 @@ import           Foundation.Primitive.Types.OffsetSize import           Foundation.Numerical import           Foundation.Primitive.Types+import           Foundation.Primitive import           GHC.ST  @@ -38,6 +39,8 @@  instance PrimType ty => Eq (ChunkedUArray ty) where   (==) = equal+instance NormalForm (ChunkedUArray ty) where+    toNormalForm (ChunkedUArray spine) = toNormalForm spine  instance Monoid (ChunkedUArray a) where     mempty  = empty

@@ -17,6 +17,11 @@     , withPtr     , recast     , toHexadecimal+    -- * Mutable facilities+    , new+    , newPinned+    , withMutablePtr     ) where  import           Foundation.Array.Unboxed+import           Foundation.Array.Unboxed.Mutable

@@ -104,6 +104,7 @@ import qualified Foundation.Primitive.Base16 as Base16 import           Foundation.Primitive.Monad import           Foundation.Primitive.Types+import           Foundation.Primitive.NormalForm import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.Utils@@ -136,6 +137,9 @@ arrayType :: DataType arrayType = mkNoRepType "Foundation.UArray" +instance NormalForm (UArray ty) where+    toNormalForm (UVecBA _ _ _ !_) = ()+    toNormalForm (UVecAddr _ _ _) = () instance (PrimType ty, Show ty) => Show (UArray ty) where     show v = show (toList v) instance (PrimType ty, Eq ty) => Eq (UArray ty) where@@ -359,9 +363,16 @@ ----------------------------------------------------------------------- -- higher level collection implementation -----------------------------------------------------------------------+data BA0 = BA0 !ByteArray# -- zero ba -empty :: PrimType ty => UArray ty-empty = UVecAddr (Offset 0) (Size 0) (FinalPtr $ error "empty de-referenced")+empty_ :: BA0+empty_ = runST $ primitive $ \s1 ->+    case newByteArray# 0# s1           of { (# s2, mba #) ->+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->+        (# s3, BA0 ba #) }}++empty :: UArray ty+empty = UVecBA 0 0 unpinned ba where !(BA0 ba) = empty_  singleton :: PrimType ty => ty -> UArray ty singleton ty = create 1 (const ty)

@@ -137,8 +137,8 @@                 !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz         {-# INLINE newFake #-} -empty :: (PrimMonad prim, PrimType ty) => prim (MUArray ty (PrimState prim))-empty = newUnpinned 0+empty :: PrimMonad prim => prim (MUArray ty (PrimState prim))+empty = primitive $ \s1 -> case newByteArray# 0# s1 of { (# s2, mba #) -> (# s2, MUVecMA 0 0 unpinned mba #) }  -- | Create a new mutable array of size @n. --

@@ -9,6 +9,7 @@     , oneof     , elements     , frequency+    , between     -- test     , Test(..)     , testName@@ -20,6 +21,7 @@     , propertyCompare     , propertyAnd     , propertyFail+    , forAll     -- * As Program     , defaultMain     ) where@@ -112,7 +114,7 @@         loop :: Word -> [String] -> [String]         loop _ []      = printChecks checks         loop !i (a:as) = "parameter " <> fromList (show i) <> " : " <> a <> "\n" : loop (i+1) as-    printChecks (PropertyBinaryOp True name _ _)  = []+    printChecks (PropertyBinaryOp True _ _ _)     = []     printChecks (PropertyBinaryOp False name a b) = [name <> " checked fail\n" <> "   left: " <> a <> "\n" <> "  right: " <> b]     printChecks (PropertyNamed True _)            = []     printChecks (PropertyNamed False name)        = ["Check " <> name <> " failed"]

@@ -12,7 +12,7 @@ import           Foundation.Internal.Natural import           Foundation.Primitive import           Foundation.Primitive.IntegralConv (wordToChar)-import           Foundation.Primitive.Floating (integerToDouble, naturalToDouble, doubleExponant)+import           Foundation.Primitive.Floating import           Foundation.Check.Gen import           Foundation.Random import           Foundation.Bits@@ -62,6 +62,10 @@     arbitrary = genWithParams $ \params ->         fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (integralCast i) arbitrary) +instance Arbitrary Float where+    arbitrary = toFloat <$> arbitrary <*> arbitrary <*> arbitrary+      where toFloat i n Nothing  = integerToFloat i + (naturalToFloat n / 100000)+            toFloat i n (Just e) = (integerToFloat i + (naturalToFloat n / 1000000)) * (integerToFloat e) instance Arbitrary Double where     arbitrary = toDouble <$> arbitrary <*> arbitrary <*> arbitrary       where toDouble i n Nothing  = integerToDouble i + (naturalToDouble n / 100000)

@@ -3,6 +3,7 @@     , ResourceT     , ZipSink (..)     , await+    , awaitForever     , yield     , yieldOr     , leftover

@@ -18,6 +18,7 @@     , MonadResource(..)     , runResourceT     , await+    , awaitForever     , yield     , yieldOr     , leftover@@ -143,6 +144,11 @@     (const $ unConduit f rest) {-# INLINE await' #-} {-# RULES "conduit: await >>= maybe" [2] forall x y. await >>= maybe x y = await' x y #-}++awaitForever :: (input -> Conduit input output monad b) -> Conduit input output monad ()+awaitForever f = Conduit $ \rest ->+    let go = Await (\i -> unConduit (f i) (const go)) rest+     in go  -- | Send a value downstream. yield :: Monad m => o -> Conduit i o m ()

@@ -0,0 +1,52 @@+module Foundation.Conduit.Textual+    ( lines+    , fromBytes+    , toBytes+    ) where++import           Foundation.Internal.Base hiding (throw)+import           Foundation.Array.Unboxed (UArray)+import           Foundation.String (String)+import           Foundation.Collection+import qualified Foundation.String.UTF8 as S+import           Foundation.Conduit.Internal+import           Foundation.Monad++-- | Split conduit of string to its lines+--+-- This is very similar to Prelude lines except+-- it work directly on Conduit+--+-- Note that if the newline character is not coming,+-- this function will keep accumulating data until OOM+lines :: Monad m => Conduit String String m ()+lines = await >>= maybe (finish []) (go [])+  where+    mconcatRev = mconcat . reverse++    finish l = if null l then return () else yield (mconcatRev l)++    go prevs nextBuf =+        case S.uncons next' of+            Just (_, rest') -> yield (mconcatRev (line : prevs)) >> go mempty rest'+            Nothing         ->+                let nextCurrent = nextBuf : prevs+                 in await >>= maybe (finish nextCurrent) (go nextCurrent)+      where (line, next') = S.breakElem '\n' nextBuf++fromBytes :: MonadThrow m => S.Encoding -> Conduit (UArray Word8) String m ()+fromBytes encoding = loop mempty+  where+    loop r = await >>= maybe (finish r) (go r)+    finish buf | null buf  = return ()+               | otherwise = case S.fromBytes encoding buf of+                                    (s, Nothing, _)  -> yield s+                                    (_, Just err, _) -> throw err+    go current nextBuf =+        case S.fromBytes encoding (current `mappend` nextBuf) of+            (s, Nothing           , r) -> yield s >> loop r+            (s, Just S.MissingByte, r) -> yield s >> loop r+            (_, Just err          , _) -> throw err++toBytes :: Monad m => S.Encoding -> Conduit String (UArray Word8) m ()+toBytes encoding = awaitForever $ \a -> pure (S.toBytes encoding a) >>= yield

@@ -11,6 +11,8 @@     -- * Terminal       Foundation.IO.Terminal.putStrLn     , Foundation.IO.Terminal.putStr+    , Foundation.IO.Terminal.stdin+    , Foundation.IO.Terminal.stdout     -- * File     , Foundation.IO.File.IOMode(..)     , Foundation.IO.File.openFile

@@ -8,11 +8,14 @@ module Foundation.IO.Terminal     ( putStrLn     , putStr+    , stdin+    , stdout     ) where  import           Foundation.Internal.Base import           Foundation.String import qualified Prelude+import           System.IO (stdin, stdout)  -- | Print a string to standard output putStr :: String -> IO ()

@@ -21,14 +21,14 @@ import           System.Posix.Types  -- | Integral Literal support--- +-- -- e.g. 123 :: Integer --      123 :: Word8 class Integral a where     fromInteger :: Integer -> a  -- | Fractional Literal support--- +-- -- e.g. 1.2  :: Double --      0.03 :: Float class Fractional a where@@ -69,6 +69,8 @@ instance Integral CInt where     fromInteger a = Prelude.fromInteger a instance Integral COff where+    fromInteger a = Prelude.fromInteger a+instance Integral CUIntPtr where     fromInteger a = Prelude.fromInteger a  instance Integral Float where

@@ -0,0 +1,88 @@+-- |+-- Module      : Foundation.List.DList+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- Stability   : statble+-- Portability : portable+--+-- Data structure for optimised operations (append, cons, snoc) on list+--+module Foundation.List.DList+    ( DList+    ) where++import Foundation.Internal.Base+import Foundation.Collection+import Foundation.Class.Bifunctor++newtype DList a = DList { unDList :: [a] -> [a] }+  deriving (Typeable)++instance Eq a => Eq (DList a) where+    (==) dl1 dl2 = (==) (toList dl1) (toList dl2)++instance Ord a => Ord (DList a) where+    compare dl1 dl2 = compare (toList dl1) (toList dl2)++instance Show a => Show (DList a) where+    show = show . toList++instance IsList (DList a) where+    type Item (DList a) = a+    fromList = DList . (<>)+    toList = flip unDList []++instance Monoid (DList a) where+    mempty = DList id+    mappend dl1 dl2 = DList $ unDList dl1 . unDList dl2++instance Functor DList where+    fmap f = foldr (cons . f) mempty++instance Applicative DList where+    pure = singleton+    (<*>) m1 m2 = m1 >>= \x1 -> m2 >>= \x2 -> return (x1 x2)++instance Monad DList where+    (>>=) m k = foldr (mappend . k) mempty m+    return = singleton++type instance Element (DList a) = a++instance Foldable (DList a) where+    foldr f b = foldr f b . toList+    foldl f b = foldl f b . toList+    foldl' f b = foldl' f b . toList++instance Collection (DList a) where+    null = null . toList+    length = length . toList+    elem a = elem a . toList+    maximum = maximum . nonEmpty_ . toList+    minimum = minimum . nonEmpty_ . toList+    all f = all f . toList+    any f = any f . toList++instance Sequential (DList a) where+    take n = fromList . take n . toList+    revTake n = fromList . revTake n . toList+    drop n = fromList . drop n . toList+    revDrop n = fromList . revDrop n . toList+    splitAt n = bimap fromList fromList . splitAt n . toList+    splitOn f = fmap fromList . splitOn f . toList+    break f = bimap fromList fromList . break f . toList+    breakElem e = bimap fromList fromList . breakElem e . toList+    intersperse e = fromList . intersperse e . toList+    intercalate e = intercalate e . toList+    span f = bimap fromList fromList . span f . toList+    filter f = fromList . filter f . toList+    partition f = bimap fromList fromList . partition f . toList+    reverse = fromList . reverse . toList+    uncons dl = second fromList <$> uncons (toList dl)+    unsnoc dl = first fromList <$> unsnoc (toList dl)+    cons e dl = DList $ (:) e . unDList dl+    snoc dl e = DList $ unDList dl . (:) e+    find f = find f . toList+    sortBy comp = fromList . sortBy comp . toList+    singleton = DList . (:)+    replicate n e = fromList $ replicate n e

@@ -4,13 +4,20 @@ -- This is useful to keep a non-modifiable value -- in a context module Foundation.Monad.Reader-    ( ReaderT+    ( -- * MonadReader+      MonadReader(..)+    , -- * ReaderT+      ReaderT     , runReaderT     ) where  import Foundation.Internal.Base (($), (.), const) import Foundation.Monad.Base +class Monad m => MonadReader m where+    type ReaderContext m+    ask :: m (ReaderContext m)+ -- | Reader Transformer newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } @@ -47,3 +54,7 @@  instance MonadCatch m => MonadCatch (ReaderT r m) where     catch (ReaderT m) c = ReaderT $ \r -> m r `catch` (\e -> runReaderT (c e) r)++instance Monad m => MonadReader (ReaderT r m) where+    type ReaderContext (ReaderT r m) = r+    ask = ReaderT return

@@ -1,12 +1,28 @@ {-# LANGUAGE TupleSections #-} module Foundation.Monad.State-    ( StateT+    ( -- * MonadState+      MonadState(..)+    , get+    , put++    , -- * StateT+      StateT     , runStateT     ) where -import Foundation.Internal.Base (($), (.))+import Foundation.Internal.Base (($), (.), const) import Foundation.Monad.Base +class Monad m => MonadState m where+    type State m+    withState :: (State m -> (a, State m)) -> m a++get :: MonadState m => m (State m)+get = withState $ \s -> (s, s)++put :: MonadState m => State m -> m ()+put s = withState $ const ((), s)+ -- | State Transformer newtype StateT s m a = StateT { runStateT :: s -> m (a, s) } @@ -46,3 +62,7 @@  instance (Functor m, MonadCatch m) => MonadCatch (StateT s m) where     catch (StateT m) c = StateT $ \s1 -> m s1 `catch` (\e -> runStateT (c e) s1)++instance (Functor m, Monad m) => MonadState (StateT s m) where+    type State (StateT s m) = s+    withState f = StateT $ return . f

@@ -32,9 +32,11 @@  -- | IPv4 data type newtype IPv4 = IPv4 Word32-  deriving (Eq, Ord, Typeable, Hashable)+    deriving (Eq, Ord, Typeable, Hashable) instance Show IPv4 where     show = toLString+instance NormalForm IPv4 where+    toNormalForm !_ = () instance IsString IPv4 where     fromString = fromLString instance Storable IPv4 where

@@ -43,7 +43,9 @@  -- | IPv6 data type data IPv6 = IPv6 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64-  deriving (Eq, Ord, Typeable)+    deriving (Eq, Ord, Typeable)+instance NormalForm IPv6 where+    toNormalForm !_ = () instance Hashable IPv6 where     hashMix (IPv6 w1 w2) = hashMix w1 . hashMix w2 instance Show IPv6 where

@@ -23,9 +23,15 @@     , IntegralUpsize(..)     , IntegralDownsize(..)     , IntegralCast(..)++    -- * Evaluation+    , NormalForm(..)+    , force+    , deepseq     ) where  import Foundation.Primitive.Types import Foundation.Primitive.Monad import Foundation.Primitive.Endianness import Foundation.Primitive.IntegralConv+import Foundation.Primitive.NormalForm

@@ -2,6 +2,8 @@     ( integerToDouble     , naturalToDouble     , doubleExponant+    , integerToFloat+    , naturalToFloat     ) where  import           GHC.Types@@ -19,3 +21,9 @@  doubleExponant :: Double -> Int -> Double doubleExponant = (Prelude.^^)++integerToFloat :: Integer -> Float+integerToFloat = Prelude.fromInteger++naturalToFloat :: Natural -> Float+naturalToFloat = integerToFloat . Prelude.toInteger

@@ -0,0 +1,116 @@+module Foundation.Primitive.NormalForm+    ( NormalForm(..)+    , deepseq+    , force+    ) where++import Foundation.Internal.Base+import Foundation.Internal.Natural+import Foundation.Primitive.Types.OffsetSize+import Foreign.C.Types++-- | Data that can be fully evaluated in Normal Form+--+class NormalForm a where+    toNormalForm :: a -> ()++deepseq :: NormalForm a => a -> b -> b+deepseq a b = toNormalForm a `seq` b++force :: NormalForm a => a -> a+force a = toNormalForm a `seq` a++-----+-- GHC / base types++instance NormalForm Int8    where toNormalForm !_ = ()+instance NormalForm Int16   where toNormalForm !_ = ()+instance NormalForm Int32   where toNormalForm !_ = ()+instance NormalForm Int64   where toNormalForm !_ = ()+instance NormalForm Int     where toNormalForm !_ = ()+instance NormalForm Integer where toNormalForm !_ = ()++instance NormalForm Word8   where toNormalForm !_ = ()+instance NormalForm Word16  where toNormalForm !_ = ()+instance NormalForm Word32  where toNormalForm !_ = ()+instance NormalForm Word64  where toNormalForm !_ = ()+instance NormalForm Word    where toNormalForm !_ = ()+instance NormalForm Natural where toNormalForm !_ = ()++instance NormalForm Float  where toNormalForm !_ = ()+instance NormalForm Double where toNormalForm !_ = ()++instance NormalForm Char where toNormalForm !_ = ()+instance NormalForm Bool where toNormalForm !_ = ()+instance NormalForm ()   where toNormalForm !_ = ()++-----+-- C Types+instance NormalForm CChar  where toNormalForm !_ = ()+instance NormalForm CUChar where toNormalForm !_ = ()+instance NormalForm CSChar where toNormalForm !_ = ()++instance NormalForm CShort  where toNormalForm !_ = ()+instance NormalForm CUShort where toNormalForm !_ = ()+instance NormalForm CInt    where toNormalForm !_ = ()+instance NormalForm CUInt   where toNormalForm !_ = ()+instance NormalForm CLong   where toNormalForm !_ = ()+instance NormalForm CULong  where toNormalForm !_ = ()+instance NormalForm CLLong  where toNormalForm !_ = ()+instance NormalForm CULLong where toNormalForm !_ = ()++instance NormalForm CFloat  where toNormalForm !_ = ()+instance NormalForm CDouble where toNormalForm !_ = ()++instance NormalForm (Ptr a) where toNormalForm !_ = ()++-----+-- Basic Foundation primitive types+instance NormalForm (Offset a) where toNormalForm !_ = ()+instance NormalForm (Size a) where toNormalForm !_ = ()++-----+-- composed type++instance NormalForm a => NormalForm (Maybe a) where+    toNormalForm Nothing  = ()+    toNormalForm (Just a) = toNormalForm a `seq` ()+instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where+    toNormalForm (Left l)  = toNormalForm l `seq` ()+    toNormalForm (Right r) = toNormalForm r `seq` ()++instance NormalForm a => NormalForm [a] where+    toNormalForm []     = ()+    toNormalForm (x:xs) = toNormalForm x `seq` toNormalForm xs++instance (NormalForm a, NormalForm b) => NormalForm (a,b) where+    toNormalForm (a,b) = toNormalForm a `seq` toNormalForm b++instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (a,b,c) where+    toNormalForm (a,b,c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (a,b,c,d) where+    toNormalForm (a,b,c,d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e)+      => NormalForm (a,b,c,d,e) where+    toNormalForm (a,b,c,d,e) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f)+      => NormalForm (a,b,c,d,e,f) where+    toNormalForm (a,b,c,d,e,f) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e `seq` toNormalForm f++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g)+      => NormalForm (a,b,c,d,e,f,g) where+    toNormalForm (a,b,c,d,e,f,g) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e `seq` toNormalForm f `seq` toNormalForm g+instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d, NormalForm e, NormalForm f, NormalForm g, NormalForm h)+      => NormalForm (a,b,c,d,e,f,g,h) where+    toNormalForm (a,b,c,d,e,f,g,h) =+        toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d `seq`+        toNormalForm e `seq` toNormalForm f `seq` toNormalForm g `seq` toNormalForm h

@@ -1,7 +1,9 @@ module Foundation.String.Read     ( readInteger+    , readIntegral     , readNatural     , readDouble+    , readRational     , readFloatingExact     ) where 

@@ -67,8 +67,10 @@     , builderAppend     , builderBuild     , readInteger+    , readIntegral     , readNatural     , readDouble+    , readRational     , readFloatingExact     -- * Legacy utility     , lines@@ -89,6 +91,7 @@ import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Primitive.Types+import           Foundation.Primitive.NormalForm import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Floating import           Foundation.Boot.Builder@@ -105,6 +108,7 @@  -- temporary import qualified Data.List import           Data.Data+import           Data.Ratio import qualified Prelude  import           Foundation.String.ModifiedUTF8     (fromModified)@@ -126,6 +130,9 @@     dataTypeOf _ = stringType     gunfold _ _  = error "gunfold" +instance NormalForm String where+    toNormalForm (String ba) = toNormalForm ba+ stringType :: DataType stringType = mkNoRepType "Foundation.String" @@ -358,6 +365,42 @@   where     !w = Vec.unsafeIndex ba n +-- same as nextAscii but with a ByteArray#+nextAsciiBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)+nextAsciiBA ba n = (# w, not (testBit w 7) #)+  where+    !w = primBaIndex ba n+{-# INLINE nextAsciiBA #-}++-- same as nextAscii but with a ByteArray#+nextAsciiPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)+nextAsciiPtr (Ptr addr) n = (# w, not (testBit w 7) #)+  where !w = primAddrIndex addr n+{-# INLINE nextAsciiPtr #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigitBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)+nextAsciiDigitBA ba n = (# d, d < 0xa #)+  where !d = primBaIndex ba n - 0x30+{-# INLINE nextAsciiDigitBA #-}++nextAsciiDigitPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)+nextAsciiDigitPtr (Ptr addr) n = (# d, d < 0xa #)+  where !d = primAddrIndex addr n - 0x30+{-# INLINE nextAsciiDigitPtr #-}++expectAscii :: String -> Offset8 -> Word8 -> Bool+expectAscii (String ba) n v = Vec.unsafeIndex ba n == v+{-# INLINE expectAscii #-}++expectAsciiBA :: ByteArray# -> Offset8 -> Word8 -> Bool+expectAsciiBA ba n v = primBaIndex ba n == v+{-# INLINE expectAsciiBA #-}++expectAsciiPtr :: Ptr Word8 -> Offset8 -> Word8 -> Bool+expectAsciiPtr (Ptr ptr) n v = primAddrIndex ptr n == v+{-# INLINE expectAsciiPtr #-}+ next :: String -> Offset8 -> (# Char, Offset8 #) next (String ba) n =     case getNbBytes# h of@@ -692,10 +735,12 @@  -- | 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-        UTF8_1 w -> let (# v1,v2 #) = Vec.splitElem w ba in (String v1, String v2)-        _        -> runST $ Vec.unsafeIndexer ba go+breakElem !el s@(String ba)+    | sz == 0   = (mempty, mempty)+    | otherwise =+        case asUTF8Char el of+            UTF8_1 w -> let (# v1,v2 #) = Vec.splitElem w ba in (String v1, String v2)+            _        -> runST $ Vec.unsafeIndexer ba go   where     sz = size s     end = azero `offsetPlusE` sz@@ -877,12 +922,14 @@  -- | 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)-     in runST $ do-            dest <- new nbBytes-            copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes)-            freeze dest+charMap f src+    | srcSz == 0 = mempty+    | otherwise  =+        let !(elems, nbBytes) = allocateAndFill [] (Offset 0) (Size 0)+         in runST $ do+                dest <- new nbBytes+                copyLoop dest elems (Offset 0 `offsetPlusE` nbBytes)+                freeze dest   where     !srcSz = size src     srcEnd = azero `offsetPlusE` srcSz@@ -1250,23 +1297,42 @@         Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz         fillFromEnd (end - sz) xs mba +stringDewrap :: (ByteArray# -> Offset Word8 -> a)+             -> (Ptr Word8 -> Offset Word8 -> ST s a)+             -> String+             -> a+stringDewrap withBa withPtr (String ba) = C.unsafeDewrap withBa withPtr ba+{-# INLINE stringDewrap #-}+ -- | Read an Integer from a String -- -- Consume an optional minus sign and many digits until end of string.-readInteger :: String -> Maybe Integer-readInteger str-    | sz == 0  = Nothing-    | otherwise =-         let (# modF, startOfs #) = case nextAscii str 0 of-                                        -- '-'-                                        (# 0x2d, True #) -> (# negate , 1 #)-                                        _                -> (# id, 0 #)-          in case decimalDigits 0 str startOfs of-                (# acc, True, endOfs #) | endOfs > startOfs -> Just $ modF acc-                _                                           -> Nothing+readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i+readIntegral str+    | sz == 0   = Nothing+    | otherwise = stringDewrap withBa withPtr str   where     !sz = size str+    withBa ba ofs =+        let negativeSign = expectAsciiBA ba ofs 0x2d+            startOfs     = if negativeSign then succ ofs else ofs+         in case decimalDigitsBA 0 ba endOfs startOfs of+                (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc+                _                                             -> Nothing+      where !endOfs = ofs `offsetPlusE` sz+    withPtr ptr ofs = return $+        let negativeSign = expectAsciiPtr ptr ofs 0x2d+            startOfs     = if negativeSign then succ ofs else ofs+         in case decimalDigitsPtr 0 ptr endOfs startOfs of+                (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc+                _                                             -> Nothing+      where !endOfs = ofs `offsetPlusE` sz+{-# SPECIALISE readIntegral :: String -> Maybe Integer #-}+{-# SPECIALISE readIntegral :: String -> Maybe Int #-} +readInteger :: String -> Maybe Integer+readInteger = readIntegral+ -- | Read a Natural from a String -- -- Consume many digits until end of string.@@ -1283,22 +1349,41 @@ -- | Try to read a Double readDouble :: String -> Maybe Double readDouble s =-    readFloatingExact s $ \isNegative integral mFloating mExponant ->-        case (mFloating, mExponant) of-            (Nothing, Nothing)             -> Just $ applySign isNegative $                         naturalToDouble integral-            (Nothing, Just exponant)       -> Just $ applySign isNegative $ withExponant exponant $ naturalToDouble integral-            (Just floating, Nothing)       -> Just $ applySign isNegative $                         (naturalToDouble integral + floatingToDouble floating)-            (Just floating, Just exponant) -> Just $ applySign isNegative $ withExponant exponant $ (naturalToDouble integral + floatingToDouble floating)+    readFloatingExact s $ \isNegative integral floatingDigits mExponant ->+        Just $ applySign isNegative $ case (floatingDigits, mExponant) of+            (0, Nothing)              ->                         naturalToDouble integral+            (0, Just exponent)        -> withExponant exponent $ naturalToDouble integral+            (floating, Nothing)       ->                         applyFloating floating $ naturalToDouble integral+            (floating, Just exponent) -> withExponant exponent $ applyFloating floating $ naturalToDouble integral   where     applySign True = negate     applySign False = id     withExponant e v = v * doubleExponant 10 e-    floatingToDouble (digits, n) = naturalToDouble n / (10 ^ digits)+    applyFloating digits n = n / (10 Prelude.^ digits) -type ReadFloatingCallback a = Bool                  -- sign-                           -> Natural               -- integral part-                           -> Maybe (Word, Natural) -- optional number of zero and number representing floating part-                           -> Maybe Int             -- optional integer representing exponent in base 10+-- | Try to read a floating number as a Rational+--+-- Note that for safety reason, only exponent between -10000 and 10000 is allowed+-- as otherwise DoS/OOM is very likely. if you don't want this behavior,+-- switching to a scientific type (not provided yet) that represent the+-- exponent separately is the advised solution.+readRational :: String -> Maybe Prelude.Rational+readRational s =+    readFloatingExact s $ \isNegative integral floatingDigits mExponant ->+        case mExponant of+            Just exponent+                | exponent < -10000 || exponent > 10000 -> Nothing+                | otherwise                             -> Just $ modF isNegative integral % (10 Prelude.^ (integralCast floatingDigits - exponent))+            Nothing                                     -> Just $ modF isNegative integral % (10 Prelude.^ floatingDigits)+  where+    modF True  = negate . integralUpsize+    modF False = integralUpsize+++type ReadFloatingCallback a = Bool      -- sign+                           -> Natural   -- integral part+                           -> Word      -- number of digits in floating section+                           -> Maybe Int -- optional integer representing exponent in base 10                            -> Maybe a  -- | Read an Floating like number of the form:@@ -1308,9 +1393,9 @@ -- Call a function with: -- -- * A boolean representing if the number is negative--- * The leading integral part--- * The floating part (number of digits after fractional part, and number) if any--- * The exponant if any+-- * The digits part represented as a single natural number (123.456 is represented as 123456)+-- * The number of digits in the fractional part (e.g. 123.456 => 3)+-- * The exponent if any -- -- The code is structured as a simple state machine that: --@@ -1318,79 +1403,97 @@ -- * Consume number for the integral part -- * Optionally --   * Consume '.'---   * Consume leading zeros explicitely to gather scale of the fractional part --   * Consume remaining digits if not already end of string -- * Optionally Consume a 'e' or 'E' follow by an optional '-' and a number -- readFloatingExact :: String -> ReadFloatingCallback a -> Maybe a readFloatingExact str f     | sz == 0   = Nothing-    | otherwise =-        -- try to eat a '-', otherwise call consumeIntegral-        case nextAscii str 0 of-            (# _   , False #) -> Nothing-            (# 0x2d, True #)  -> consumeIntegral True 1-            _                 -> consumeIntegral False 0+    | otherwise = stringDewrap withBa withPtr str   where     !sz = size str -    consumeIntegral isNegative startOfs =-        case decimalDigits 0 str startOfs of-            (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc Nothing Nothing -- end of stream and no '.'-            (# acc, False, endOfs #) | endOfs > startOfs -> consumeDot isNegative acc endOfs-            _                                            -> Nothing+    withBa ba stringStart =+        let !isNegative = expectAsciiBA ba stringStart 0x2d+         in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)+      where+        eofs = stringStart `offsetPlusE` sz+        consumeIntegral !isNegative startOfs =+            case decimalDigitsBA 0 ba eofs startOfs of+                (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.'+                (# acc, False, endOfs #) | endOfs > startOfs ->+                    if expectAsciiBA ba endOfs 0x2e+                        then consumeFloat isNegative acc (endOfs + 1)+                        else consumeExponant isNegative acc 0 endOfs+                _                                            -> Nothing -    -- this is not the end of the stream since otherwise consumeIntegral would have-    -- returned already-    -- try either to consume '.' or pass state to consumeExponant-    consumeDot isNegative integral startOfs =-        case nextAscii str startOfs of-            (# _   , False #) -> Nothing-            (# 0x2e, True #)  -> consumeZero isNegative integral (startOfs + 1)-            (# _   , True #)  -> consumeExponant isNegative integral Nothing startOfs+        consumeFloat isNegative integral startOfs =+            case decimalDigitsBA integral ba eofs startOfs of+                (# acc, True, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                                                                in f isNegative acc (integralCast diff) Nothing+                (# acc, False, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                                                                in consumeExponant isNegative acc (integralCast diff) endOfs+                _                                           -> Nothing -    consumeZero isNegative integral startOfs = loop 0 startOfs+        consumeExponant !isNegative !integral !floatingDigits !startOfs+            | startOfs == eofs = f isNegative integral floatingDigits Nothing+            | otherwise        =+                -- consume 'E' or 'e'+                case nextAsciiBA ba startOfs of+                    (# 0x45, True #) -> consumeExponantSign (startOfs+1)+                    (# 0x65, True #) -> consumeExponantSign (startOfs+1)+                    (# _   , _    #) -> Nothing+          where+            consumeExponantSign ofs+                | ofs == eofs = Nothing+                | otherwise   = let exponentNegative = expectAsciiBA ba ofs 0x2d+                                 in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs)++            consumeExponantNumber exponentNegative ofs =+                case decimalDigitsBA 0 ba eofs ofs of+                    (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc)+                    _                                      -> Nothing+    withPtr ptr stringStart = return $+        let !isNegative = expectAsciiPtr ptr stringStart 0x2d+         in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart)       where-        loop nbDigits ofs-            | ofs .==# sz = if nbDigits == 0 then Nothing else f isNegative integral (Just (nbDigits, 0)) Nothing-            | otherwise   =-                case nextAscii str ofs of-                    (# _   , False #) -> Nothing-                    (# 0x30, True #)  -> loop (nbDigits+1) (ofs+1)-                    (# c   , True #)-                        | c == 0x45 || c == 0x65 -> if nbDigits > 0 then consumeExponant isNegative integral (Just (nbDigits, 0)) ofs else Nothing-                        | otherwise              -> consumeFloat isNegative integral nbDigits ofs+        eofs = stringStart `offsetPlusE` sz+        consumeIntegral !isNegative startOfs =+            case decimalDigitsPtr 0 ptr eofs startOfs of+                (# acc, True , endOfs #) | endOfs > startOfs -> f isNegative acc 0 Nothing -- end of stream and no '.'+                (# acc, False, endOfs #) | endOfs > startOfs ->+                    if expectAsciiPtr ptr endOfs 0x2e+                        then consumeFloat isNegative acc (endOfs + 1)+                        else consumeExponant isNegative acc 0 endOfs+                _                                            -> Nothing -    consumeFloat isNegative integral nbDigits startOfs =-        case decimalDigits 0 str startOfs of-            (# acc, True, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs-                                                            in f isNegative integral (Just (nbDigits+integralCast diff, acc)) Nothing-            (# acc, False, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs-                                                            in consumeExponant isNegative integral (Just (nbDigits+integralCast diff, acc)) endOfs-            _                                           -> Nothing+        consumeFloat isNegative integral startOfs =+            case decimalDigitsPtr integral ptr eofs startOfs of+                (# acc, True, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                                                                in f isNegative acc (integralCast diff) Nothing+                (# acc, False, endOfs #) | endOfs > startOfs -> let (Size !diff) = endOfs - startOfs+                                                                in consumeExponant isNegative acc (integralCast diff) endOfs+                _                                           -> Nothing -    consumeExponant !isNegative !integral !floating !startOfs-        | startOfs .==# sz = f isNegative integral floating Nothing-        | otherwise        =-            -- consume 'E' or 'e'-            case nextAscii str startOfs of-                (# _   , False #) -> Nothing -- more character but no ascii-                (# 0x45, True  #) -> consumeExponantSign (startOfs+1)-                (# 0x65, True  #) -> consumeExponantSign (startOfs+1)-                (# _   , True  #) -> Nothing-      where-        consumeExponantSign ofs-            | ofs .==# sz = Nothing-            | otherwise   =-                case nextAscii str ofs of-                    (# _   , False #) -> Nothing-                    (# 0x2d, True  #) -> consumeExponantNumber negate (ofs+1)-                    (# _   , True  #) -> consumeExponantNumber id     ofs-        consumeExponantNumber signFct ofs =-            case decimalDigits 0 str ofs of-                (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floating (Just $ signFct acc)-                _                                      -> Nothing+        consumeExponant !isNegative !integral !floatingDigits !startOfs+            | startOfs == eofs = f isNegative integral floatingDigits Nothing+            | otherwise        =+                -- consume 'E' or 'e'+                case nextAsciiPtr ptr startOfs of+                    (# 0x45, True #) -> consumeExponantSign (startOfs+1)+                    (# 0x65, True #) -> consumeExponantSign (startOfs+1)+                    (# _   , _    #) -> Nothing+          where+            consumeExponantSign ofs+                | ofs == eofs = Nothing+                | otherwise   = let exponentNegative = expectAsciiPtr ptr ofs 0x2d+                                 in consumeExponantNumber exponentNegative (if exponentNegative then ofs + 1 else ofs) +            consumeExponantNumber exponentNegative ofs =+                case decimalDigitsPtr 0 ptr eofs ofs of+                    (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc)+                    _                                      -> Nothing+ -- | Take decimal digits and accumulate it in `acc` -- -- The loop starts at the offset specified and finish either when:@@ -1431,3 +1534,43 @@     ascii9 = 0x39     isDigit c = c >= ascii0 && c <= ascii9     fromDigit c = integralUpsize (c - ascii0)++-- | same as decimalDigitsBA for a bytearray#+decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)+                => acc+                -> ByteArray#+                -> Offset Word8 -- end offset+                -> Offset Word8 -- start offset+                -> (# acc, Bool, Offset Word8 #)+decimalDigitsBA startAcc ba !endOfs !startOfs = loop startAcc startOfs+  where+    loop !acc !ofs+        | ofs == endOfs = (# acc, True, ofs #)+        | otherwise     =+            case nextAsciiDigitBA ba ofs of+                (# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)+                (# _, _ #)    -> (# acc, False, ofs #)+{-# SPECIALIZE decimalDigitsBA :: Integer -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Natural -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Int -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsBA :: Word -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}++-- | same as decimalDigitsBA specialized for ptr #+decimalDigitsPtr :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc)+                 => acc+                 -> Ptr Word8+                 -> Offset Word8 -- end offset+                 -> Offset Word8 -- start offset+                 -> (# acc, Bool, Offset Word8 #)+decimalDigitsPtr startAcc ptr !endOfs !startOfs = loop startAcc startOfs+  where+    loop !acc !ofs+        | ofs == endOfs = (# acc, True, ofs #)+        | otherwise     =+            case nextAsciiDigitPtr ptr ofs of+                (# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)+                (# _, _ #)    -> (# acc, False, ofs #)+{-# SPECIALIZE decimalDigitsPtr :: Integer -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}+{-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}

@@ -38,10 +38,15 @@ sysLinux_O_TMPFILE   = 0 #endif -sysLinux_IN_NONBLOCK-    , sysLinux_IN_CLOEXEC :: CInotifyFlags+#ifdef IN_NONBLOCK+sysLinux_IN_NONBLOCK :: CInotifyFlags sysLinux_IN_NONBLOCK = (#const IN_NONBLOCK)+#endif++#ifdef IN_CLOEXEC+sysLinux_IN_CLOEXEC :: CInotifyFlags sysLinux_IN_CLOEXEC  = (#const IN_CLOEXEC)+#endif  sysLinux_IN_ACCESS     , sysLinux_IN_ATTRIB

@@ -229,9 +229,7 @@     , sysPosix_O_APPEND     , sysPosix_O_CREAT     , sysPosix_O_TRUNC-    , sysPosix_O_EXCL-    , sysPosix_O_NOFOLLOW-    , sysPosix_O_CLOEXEC :: COpenFlags+    , sysPosix_O_EXCL :: COpenFlags sysPosix_O_RDONLY   = (#const O_RDONLY) sysPosix_O_WRONLY   = (#const O_WRONLY) sysPosix_O_RDWR     = ((#const O_RDONLY) .|. (#const O_WRONLY))@@ -240,8 +238,16 @@ sysPosix_O_CREAT    = (#const O_CREAT) sysPosix_O_TRUNC    = (#const O_TRUNC) sysPosix_O_EXCL     = (#const O_EXCL)++#ifdef O_NOFOLLOW+sysPosix_O_NOFOLLOW :: COpenFlags sysPosix_O_NOFOLLOW = (#const O_NOFOLLOW)+#endif++#ifdef O_CLOEXEC+sysPosix_O_CLOEXEC :: COpenFlags sysPosix_O_CLOEXEC  = (#const O_CLOEXEC)+#endif  sysPosix_PROT_NONE     , sysPosix_PROT_READ

@@ -18,11 +18,14 @@  import Foundation.Internal.Base import Foundation.Class.Bifunctor+import Foundation.Primitive  -- | Strict tuple (a,b) data Tuple2 a b = Tuple2 !a !b     deriving (Show,Eq,Ord,Typeable,Data,Generic) +instance (NormalForm a, NormalForm b) => NormalForm (Tuple2 a b) where+    toNormalForm (Tuple2 a b) = toNormalForm a `seq` toNormalForm b instance Bifunctor Tuple2 where   bimap f g (Tuple2 a b) = Tuple2 (f a) (g b) @@ -30,9 +33,16 @@ data Tuple3 a b c = Tuple3 !a !b !c     deriving (Show,Eq,Ord,Typeable,Data,Generic) +instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (Tuple3 a b c) where+    toNormalForm (Tuple3 a b c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c+ -- | Strict tuple (a,b,c,d) data Tuple4 a b c d = Tuple4 !a !b !c !d     deriving (Show,Eq,Ord,Typeable,Data,Generic)++instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d)+      => NormalForm (Tuple4 a b c d) where+    toNormalForm (Tuple4 a b c d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d  -- | Class of product types that have a first element class Fstable a where

@@ -18,6 +18,8 @@     deriving (Eq,Ord,Typeable) instance Show UUID where     show = toLString+instance NormalForm UUID where+    toNormalForm !_ = () instance Hashable UUID where     hashMix (UUID a b) = hashMix a . hashMix b instance Storable UUID where

@@ -59,7 +59,7 @@ Advanced settings ---------------------- -Please check out the chapter [Advanced Usage Options](docs/Advanced.md) in the+Please check out the chapter [Advanced Usage Options](docs/advanced-runtime.md) in the documentation.  

@@ -7,9 +7,11 @@     , break     , reverse     , filter+    , readInt+    , readInteger     ) where -import Prelude (undefined)+import Prelude (undefined, Maybe(..))  data ByteString = ByteString @@ -20,3 +22,8 @@ break   _ _ = (undefined, undefined) reverse     = undefined filter _    = undefined++readInt :: ByteString -> Maybe (a,b)+readInt _    = undefined+readInteger :: ByteString -> Maybe (a,b)+readInteger _ = undefined

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

@@ -8,6 +8,7 @@  import Foundation import Foundation.Collection+import Foundation.String.Read import BenchUtil.Common import BenchUtil.RefData @@ -15,7 +16,9 @@  #ifdef BENCH_ALL import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ByteString (readInt, readInteger) import qualified Data.Text as Text+import qualified Data.Text.Read as Text #else import qualified Fake.ByteString as ByteString import qualified Fake.Text as Text@@ -31,6 +34,7 @@     , benchBuildable     , benchReverse     , benchFilter+    , benchRead     ]   where     diffTextString :: (String -> a)@@ -47,6 +51,23 @@         s = fromList dat         t = Text.pack dat +    diffBsTextString :: (String -> a)+                   -> (Text.Text -> b)+                   -> (ByteString.ByteString -> c)+                   -> [Char]+                   -> [Benchmark]+    diffBsTextString foundationBench textBench bytestringBench dat =+        [ bench "String" $ whnf foundationBench s+#ifdef BENCH_ALL+        , bench "Text"   $ whnf textBench t+        , bench "ByteString" $ whnf bytestringBench b+#endif+        ]+      where+        s = fromList dat+        t = Text.pack dat+        b = ByteString.pack $ Prelude.map (fromIntegral . fromEnum) dat+     allDat :: [(String, [Char])]     allDat = [ ("ascii", rdFoundationEn)              , ("mascii", rdFoundationHun)@@ -82,6 +103,35 @@         fmap (\(n, dat) -> bgroup n $ diffTextString (filter (> 'b')) (Text.filter (> 'b')) dat)             allDat +    benchRead = bgroup "Read" $+        [ bgroup "Integer"+            [ bgroup "10000" (diffTextString stringReadInteger textReadInteger (toList $ show 10000))+            , bgroup "1234567891234567890" (diffTextString stringReadInteger textReadInteger (toList $ show 1234567891234567890))+            ]+        , bgroup "Int"+            [ bgroup "12345" (diffBsTextString stringReadInt textReadInt bsReadInt (toList $ show 12345))+            ]+        , bgroup "Double"+            [ bgroup "100.56e23" (diffTextString (maybe undefined id . readDouble) (either undefined fst . Text.double) (toList $ show 100.56e23))+            , bgroup "-123.1247" (diffTextString (maybe undefined id . readDouble) (either undefined fst . Text.double) (toList $ show (-123.1247)))+            ]+        ]+      where+        bsReadInt :: ByteString.ByteString -> Int+        bsReadInt = maybe undefined fst . ByteString.readInt+        textReadInt :: Text.Text -> Int+        textReadInt = either undefined fst . Text.decimal+        stringReadInt :: String -> Int+        stringReadInt = maybe undefined id . readIntegral++        bsReadInteger :: ByteString.ByteString -> Integer+        bsReadInteger = maybe undefined fst . ByteString.readInteger+        textReadInteger :: Text.Text -> Integer+        textReadInteger = either undefined fst . Text.decimal+        stringReadInteger :: String -> Integer+        stringReadInteger = maybe undefined id . readIntegral++     toString :: ([Char] -> String) -> [Char] -> Benchmarkable     toString = whnf @@ -134,6 +184,7 @@      benchFilter = bgroup "Filter" $         fmap (\(n, dat) -> bgroup n $ diffByteString (filter (> 100)) (ByteString.filter (> 100)) dat) allDat+ --------------------------------------------------------------------------  benchsTypes = bgroup "types"

@@ -9,6 +9,7 @@  #if defined(FOUNDATION_SYSTEM_LINUX) #include <sys/syscall.h>+#include <linux/types.h> #include <linux/random.h> #include <unistd.h> #define _GNU_SOURCE

@@ -1,5 +1,5 @@ Name:                foundation-Version:             0.0.7+Version:             0.0.8 Synopsis:            Alternative prelude with batteries and no dependencies Description:     A custom prelude with no dependencies apart from base.@@ -41,18 +41,28 @@ Flag experimental   Description:       Enable building experimental features, known as highly unstable or without good support cross-platform   Default:           False-  Manual:            False+  Manual:            True  Flag bench-all   Description:       Add some comparaison benchmarks against other haskell libraries   Default:           False   Manual:            True +Flag minimal-deps+  Description:       Build fully with minimal deps (no criterion, no quickcheck, no doctest)+  Default:           False+  Manual:            True+ Flag bounds-check   Description:       Add extra friendly boundary check for unsafe array operations   Default:           False   Manual:            True +Flag doctest+  Description:       Add extra friendly boundary check for unsafe array operations+  Default:           False+  Manual:            True+ Library   Exposed-modules:   Foundation                      Foundation.Numerical@@ -62,6 +72,7 @@                      Foundation.Class.Bifunctor                      Foundation.Class.Storable                      Foundation.Conduit+                     Foundation.Conduit.Textual                      Foundation.Convertible                      Foundation.String                      Foundation.String.ASCII@@ -77,6 +88,7 @@                      Foundation.Foreign                      Foundation.Collection                      Foundation.Primitive+                     Foundation.List.DList                      Foundation.Monad                      Foundation.Monad.Reader                      Foundation.Monad.State@@ -149,6 +161,7 @@                      Foundation.Primitive.Types                      Foundation.Primitive.Types.OffsetSize                      Foundation.Primitive.Monad+                     Foundation.Primitive.NormalForm                      Foundation.Primitive.Utils                      Foundation.Primitive.IntegralConv                      Foundation.Primitive.Floating@@ -247,7 +260,10 @@                      Imports   Default-Extensions: NoImplicitPrelude                       RebindableSyntax-  Build-Depends:     base >= 3 && < 5+  if flag(minimal-deps)+    Buildable: False+  else+    Build-Depends:   base >= 3 && < 5                    , mtl                    , QuickCheck                    , tasty@@ -263,7 +279,7 @@   type:              exitcode-stdio-1.0   hs-source-dirs:    tests   Main-is:           Checks.hs-  Other-modules:+  Other-modules:      Test.Checks.Property.Collection   Default-Extensions: NoImplicitPrelude                       RebindableSyntax                       OverloadedStrings@@ -279,13 +295,18 @@   hs-source-dirs:    tests   default-language:  Haskell2010   Main-is:           DocTest.hs-  Build-Depends:     base >= 3 && < 5-                   , doctest >= 0.9   Default-Extensions: NoImplicitPrelude                       RebindableSyntax-  if impl(ghc < 7.6)+  if flag(minimal-deps)+    -- TODO: for no, force unbuildable anyway     Buildable:       False-  Buildable:         False+  else+    if flag(doctest)+      Build-Depends:     base >= 3 && < 5+                       , doctest >= 0.9+      Buildable:     True+    else+      Buildable:     False  Benchmark bench   Main-Is:           Main.hs@@ -299,7 +320,10 @@   type:              exitcode-stdio-1.0   Default-Extensions: NoImplicitPrelude                       BangPatterns-  Build-depends:     base >= 4, criterion, foundation-  if flag(bench-all)-    CPP-Options:     -DBENCH_ALL-    Build-depends:   text, attoparsec, vector, bytestring+  if flag(minimal-deps) || impl(ghc < 7.10)+    Buildable: False+  else+    Build-depends:     base >= 4, criterion, foundation+    if flag(bench-all)+      CPP-Options:     -DBENCH_ALL+      Build-depends:   text, attoparsec, vector, bytestring

@@ -1,13 +1,21 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} module Main where + import Foundation+import Foundation.Array+import Foundation.Foreign+import Foundation.List.DList import Foundation.Primitive import Foundation.Check import Foundation.String.Read-import Foundation.Numerical import qualified Prelude+import Data.Ratio +import Test.Checks.Property.Collection+ testAdditive :: forall a . (Show a, Eq a, Additive a, Arbitrary a) => Proxy a -> Test testAdditive _ = Group "Additive"     [ Property "eq"             $ azero === (azero :: a)@@ -16,12 +24,12 @@     , Property "a + b == b + a" $ \(v1 :: a) v2 -> v1 + v2 === v2 + v1     ] -readFloatingExact' :: String -> Maybe (Bool, Natural, Maybe (Word, Natural), Maybe Int)-readFloatingExact' s = readFloatingExact s (\s x y z -> Just (s,x,y,z))+readFloatingExact' :: String -> Maybe (Bool, Natural, Word, Maybe Int)+readFloatingExact' str = readFloatingExact str (\s x y z -> Just (s,x,y,z))  doubleEqualApprox :: Double -> Double -> PropertyCheck doubleEqualApprox d1 d2 = (propertyCompare pName1 (<) (negate lim) d) `propertyAnd` (propertyCompare pName2 (<) d lim)-  where +  where         d = d2 - d1          pName1 = show (negate lim) <> " < " <> show d2 <> " - " <> show d1 <> " (== " <> show d <> " )"@@ -50,13 +58,17 @@                 , Property "just-sign"     $ readFloatingExact' "-" === Nothing                 , Property "extra-content" $ readFloatingExact' "-123a" === Nothing                 , Property "no-dot-after"  $ readFloatingExact' "-123." === Nothing-                , Property "case1"         $ readFloatingExact' "-123.1" === Just (True, 123, Just (1, 1), Nothing)-                , Property "case2"         $ readFloatingExact' "10001.001" === Just (False, 10001, Just (3, 1), Nothing)+                , Property "case0"         $ readFloatingExact' "124890" === Just (False, 124890, 0, Nothing)+                , Property "case1"         $ readFloatingExact' "-123.1" === Just (True, 1231, 1, Nothing)+                , Property "case2"         $ readFloatingExact' "10001.001" === Just (False, 10001001, 3, Nothing)+{-                 , Property "any"           $ \s i (v :: Word8) n ->+                                                let (integral,floating) = i `divMod` (10^v)                                                 let vw = integralUpsize v :: Word                                                     sfloat = show n                                                     digits = integralCast (length sfloat) + vw                                                  in readFloatingExact' ((if s then "-" else "") <> show i <> "." <> replicate vw '0' <> sfloat) === Just (s, i, Just (digits, n), Nothing)+-}                 ]             , Group "Double"                 [ Property "case1" $ readDouble "96152.5" === Just 96152.5@@ -64,10 +76,81 @@                 , Property "case3" $ maybe (propertyFail "Nothing") (doubleEqualApprox 0.00001204) $ readDouble "0.00001204"                 , Property "case4" $ maybe (propertyFail "Nothing") (doubleEqualApprox 2.5e12) $ readDouble "2.5e12"                 , Property "case5" $ maybe (propertyFail "Nothing") (doubleEqualApprox 6.0e-4) $ readDouble "6.0e-4"+                , Property "case6" $ maybe (propertyFail "Nothing") ((===) (-31.548)) $ readDouble "-31.548"+                , Property "case7" $ readDouble "1e100000000" === Just (1/0)                 , Property "Prelude.read" $ \(d :: Double) -> case readDouble (show d) of                                                                   Nothing -> propertyFail "Nothing"                                                                   Just d' -> d' `doubleEqualApprox` (Prelude.read $ toList $ show d)                 ]+            , Group "rational"+                [ Property "case1" $ readRational "124.098" === Just (124098 % 1000)+                ]             ]         ]+    , collectionProperties "DList a" (Proxy :: Proxy (DList Word8)) arbitrary+    , Group "Array"+      [ Group "Unboxed"+        [ collectionProperties "UArray(W8)"  (Proxy :: Proxy (UArray Word8))  arbitrary+        , collectionProperties "UArray(W16)" (Proxy :: Proxy (UArray Word16)) arbitrary+        , collectionProperties "UArray(W32)" (Proxy :: Proxy (UArray Word32)) arbitrary+        , collectionProperties "UArray(W64)" (Proxy :: Proxy (UArray Word64)) arbitrary+        , collectionProperties "UArray(I8)"  (Proxy :: Proxy (UArray Int8))   arbitrary+        , collectionProperties "UArray(I16)" (Proxy :: Proxy (UArray Int16))  arbitrary+        , collectionProperties "UArray(I32)" (Proxy :: Proxy (UArray Int32))  arbitrary+        , collectionProperties "UArray(I64)" (Proxy :: Proxy (UArray Int64))  arbitrary+        , collectionProperties "UArray(F32)" (Proxy :: Proxy (UArray Float))  arbitrary+        , collectionProperties "UArray(F64)" (Proxy :: Proxy (UArray Double)) arbitrary+        , collectionProperties "UArray(CChar)"  (Proxy :: Proxy (UArray CChar))  (CChar <$> arbitrary)+        , collectionProperties "UArray(CUChar)" (Proxy :: Proxy (UArray CUChar)) (CUChar <$> arbitrary)+        , collectionProperties "UArray(BE W16)" (Proxy :: Proxy (UArray (BE Word16))) (toBE <$> arbitrary)+        , collectionProperties "UArray(BE W32)" (Proxy :: Proxy (UArray (BE Word32))) (toBE <$> arbitrary)+        , collectionProperties "UArray(BE W64)" (Proxy :: Proxy (UArray (BE Word64))) (toBE <$> arbitrary)+        , collectionProperties "UArray(LE W16)" (Proxy :: Proxy (UArray (LE Word16))) (toLE <$> arbitrary)+        , collectionProperties "UArray(LE W32)" (Proxy :: Proxy (UArray (LE Word32))) (toLE <$> arbitrary)+        , collectionProperties "UArray(LE W64)" (Proxy :: Proxy (UArray (LE Word64))) (toLE <$> arbitrary)+        ]+      , Group "Boxed"+        [ collectionProperties "Array(W8)"  (Proxy :: Proxy (Array Word8))  arbitrary+        , collectionProperties "Array(W16)" (Proxy :: Proxy (Array Word16)) arbitrary+        , collectionProperties "Array(W32)" (Proxy :: Proxy (Array Word32)) arbitrary+        , collectionProperties "Array(W64)" (Proxy :: Proxy (Array Word64)) arbitrary+        , collectionProperties "Array(I8)"  (Proxy :: Proxy (Array Int8))   arbitrary+        , collectionProperties "Array(I16)" (Proxy :: Proxy (Array Int16))  arbitrary+        , collectionProperties "Array(I32)" (Proxy :: Proxy (Array Int32))  arbitrary+        , collectionProperties "Array(I64)" (Proxy :: Proxy (Array Int64))  arbitrary+        , collectionProperties "Array(F32)" (Proxy :: Proxy (Array Float))  arbitrary+        , collectionProperties "Array(F64)" (Proxy :: Proxy (Array Double)) arbitrary+        , collectionProperties "Array(Int)" (Proxy :: Proxy (Array Int))  arbitrary+        , collectionProperties "Array(Int,Int)" (Proxy :: Proxy (Array (Int,Int)))  arbitrary+        , collectionProperties "Array(Integer)" (Proxy :: Proxy (Array Integer)) arbitrary+        , collectionProperties "Array(CChar)"   (Proxy :: Proxy (Array CChar))  (CChar <$> arbitrary)+        , collectionProperties "Array(CUChar)"  (Proxy :: Proxy (Array CUChar)) (CUChar <$> arbitrary)+        , collectionProperties "Array(BE W16)"  (Proxy :: Proxy (Array (BE Word16))) (toBE <$> arbitrary)+        , collectionProperties "Array(BE W32)"  (Proxy :: Proxy (Array (BE Word32))) (toBE <$> arbitrary)+        , collectionProperties "Array(BE W64)"  (Proxy :: Proxy (Array (BE Word64))) (toBE <$> arbitrary)+        , collectionProperties "Array(LE W16)"  (Proxy :: Proxy (Array (LE Word16))) (toLE <$> arbitrary)+        , collectionProperties "Array(LE W32)"  (Proxy :: Proxy (Array (LE Word32))) (toLE <$> arbitrary)+        , collectionProperties "Array(LE W64)"  (Proxy :: Proxy (Array (LE Word64))) (toLE <$> arbitrary)+        ]+      ]+    , Group "ChunkedUArray"+      [ Group "Unboxed"+        [ collectionProperties "ChunkedUArray(W8)"  (Proxy :: Proxy (ChunkedUArray Word8))  arbitrary+        , collectionProperties "ChunkedUArray(W16)" (Proxy :: Proxy (ChunkedUArray Word16)) arbitrary+        , collectionProperties "ChunkedUArray(W32)" (Proxy :: Proxy (ChunkedUArray Word32)) arbitrary+        , collectionProperties "ChunkedUArray(W64)" (Proxy :: Proxy (ChunkedUArray Word64)) arbitrary+        , collectionProperties "ChunkedUArray(I8)"  (Proxy :: Proxy (ChunkedUArray Int8))   arbitrary+        , collectionProperties "ChunkedUArray(I16)" (Proxy :: Proxy (ChunkedUArray Int16))  arbitrary+        , collectionProperties "ChunkedUArray(I32)" (Proxy :: Proxy (ChunkedUArray Int32))  arbitrary+        , collectionProperties "ChunkedUArray(I64)" (Proxy :: Proxy (ChunkedUArray Int64))  arbitrary+        , collectionProperties "ChunkedUArray(F32)" (Proxy :: Proxy (ChunkedUArray Float))  arbitrary+        , collectionProperties "ChunkedUArray(F64)" (Proxy :: Proxy (ChunkedUArray Double)) arbitrary+        , collectionProperties "ChunkedUArray(BE W16)" (Proxy :: Proxy (ChunkedUArray (BE Word16))) (toBE <$> arbitrary)+        , collectionProperties "ChunkedUArray(BE W32)" (Proxy :: Proxy (ChunkedUArray (BE Word32))) (toBE <$> arbitrary)+        , collectionProperties "ChunkedUArray(BE W64)" (Proxy :: Proxy (ChunkedUArray (BE Word64))) (toBE <$> arbitrary)+        , collectionProperties "ChunkedUArray(LE W16)" (Proxy :: Proxy (ChunkedUArray (LE Word16))) (toLE <$> arbitrary)+        , collectionProperties "ChunkedUArray(LE W32)" (Proxy :: Proxy (ChunkedUArray (LE Word32))) (toLE <$> arbitrary)+        , collectionProperties "ChunkedUArray(LE W64)" (Proxy :: Proxy (ChunkedUArray (LE Word64))) (toLE <$> arbitrary)+        ]+      ]     ]

@@ -0,0 +1,300 @@+-- |+-- Module      : Test.Checks.Property.Collection+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- This module contains all the different property tests for the Foundation's+-- collection classes.+--+-- You can either run all the collection property tests with the+-- @collectionProperties@ function or run them individually.+--++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Checks.Property.Collection+    ( collectionProperties++    , -- * properties per class+      testEqualityProperties+    , testOrderingProperties+    , testIsListPropertyies+    , testMonoidProperties+    , testCollectionProperties+    , testSequentialProperties+    ) where++import Foundation+import Foundation.Collection+import Foundation.Check++import Control.Monad (replicateM)+import qualified Prelude (replicate)++-- | convenient function to replicate thegiven Generator of `e` a randomly+-- choosen amount of time.+generateListOfElement :: Gen e -> Gen [e]+generateListOfElement = generateListOfElementMaxN 100++-- | convenient function to generate up to a certain amount of time the given+-- generator.+generateListOfElementMaxN :: Word -> Gen e -> Gen [e]+generateListOfElementMaxN n e = between (0,n) >>= flip replicateM e . fromIntegral++generateNonEmptyListOfElement :: Word -> Gen e -> Gen (NonEmpty [e])+generateNonEmptyListOfElement n e = nonEmpty_ <$> (between (1,n) >>= flip replicateM e . fromIntegral)++-- | internal helper to convert a list of element into a collection+--+fromListP :: (IsList c, Item c ~ Element c) => Proxy c -> [Element c] -> c+fromListP p = \x -> asProxyTypeOf (fromList x) p++fromListNonEmptyP :: Collection a => Proxy a -> NonEmpty [Element a] -> NonEmpty a+fromListNonEmptyP proxy = nonEmpty_ . fromListP proxy . getNonEmpty++-- | internal helper to convert a given Collection into a list of its element+--+toListP :: (IsList c, Item c ~ Element c) => Proxy c -> c -> [Element c]+toListP p x = toList (asProxyTypeOf x p)++-- | test all the diffent classes of a Foundation's collection class+--+-- * testEqualityProperties+-- * testOrderingProperties+-- * testIsListPropertyies+-- * testMonoidProperties+-- * testCollectionProperties+-- * testSequentialProperties+--+collectionProperties :: forall collection+                      . ( Sequential collection+                        , Eq collection,   Eq (Element collection)+                        , Show collection, Show (Element collection)+                        , Ord collection,  Ord (Element collection)+                        )+                     => String+                     -> Proxy collection+                     -> Gen (Element collection)+                     -> Test+collectionProperties name proxy genElement = Group name+    [ testEqualityProperties   proxy genElement+    , testOrderingProperties   proxy genElement+    , testIsListPropertyies    proxy genElement+    , testMonoidProperties     proxy genElement+    , testCollectionProperties proxy genElement+    , testSequentialProperties proxy genElement+    ]++-- | test property equality for the given Collection+--+-- This does to enforce+testEqualityProperties :: forall collection+                        . ( IsList collection+                          , Element collection ~ Item collection+                          , Eq collection,   Eq (Element collection)+                          , Show collection, Show (Element collection)+                          , Ord collection,  Ord (Element collection)+                          )+                       => Proxy collection+                       -> Gen (Element collection)+                       -> Test+testEqualityProperties proxy genElement = Group "equality"+    [ Property "x == x" $ withElements $ \l -> let col = fromListP proxy l in col === col+    , Property "x == y" $ with2Elements $ \(l1, l2) ->+        (fromListP proxy l1 == fromListP proxy l2) === (l1 == l2)+    ]+  where+    withElements f = forAll (generateListOfElement genElement) f+    with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f+++testOrderingProperties :: forall collection+                        . ( IsList collection+                          , Element collection ~ Item collection+                          , Eq collection,   Eq (Element collection)+                          , Show collection, Show (Element collection)+                          , Ord collection,  Ord (Element collection)+                          )+                       => Proxy collection+                       -> Gen (Element collection)+                       -> Test+testOrderingProperties proxy genElement = Group "ordering"+    [ Property "x `compare` y" $ with2Elements $ \(l1, l2) ->+        (fromListP proxy l1 `compare` fromListP proxy l2) === (l1 `compare` l2)+    ]+  where+    with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f++testIsListPropertyies :: forall collection+                       . ( IsList collection, Eq collection, Show collection+                         , Element collection ~ Item collection+                         , Eq (Item collection), Show (Item collection)+                         )+                      => Proxy collection+                      -> Gen (Element collection)+                      -> Test+testIsListPropertyies proxy genElement = Group "IsList"+    [ Property "fromList . toList == id" $ withElements $ \l -> (toList $ fromListP proxy l) === l+    ]+  where+    withElements f = forAll (generateListOfElement genElement) f++testMonoidProperties :: forall collection+                      . ( Monoid collection, IsList collection, Eq collection, Show collection+                        , Element collection ~ Item collection+                        , Eq (Item collection), Show (Item collection)+                        )+                     => Proxy collection+                     -> Gen (Element collection)+                     -> Test+testMonoidProperties proxy genElement = Group "Monoid"+    [ Property "mempty <> x == x" $ withElements $ \l -> let col = fromListP proxy l in (col <> mempty) === col+    , Property "x <> mempty == x" $ withElements $ \l -> let col = fromListP proxy l in (mempty <> col) === col+    , Property "x1 <> x2 == x1|x2" $ with2Elements $ \(l1,l2) ->+        (fromListP proxy l1 <> fromListP proxy l2) === fromListP proxy (l1 <> l2)+    , Property "mconcat [map fromList [e]] = fromList (concat [e])" $ withNElements $ \l ->+        mconcat (fmap (fromListP proxy) l) === fromListP proxy (mconcat l)+    ]+  where+    withElements f = forAll (generateListOfElement genElement) f+    with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f+    withNElements f = forAll (generateListOfElementMaxN 5 (generateListOfElement genElement)) f++-- | test the Foundation's @Collection@ class.+--+testCollectionProperties :: forall collection+                          . ( Collection collection+                            , Show (Element collection), Eq (Element collection)+                                                       , Ord (Element collection)+                            , Ord collection+                            )+                         => Proxy collection+                            -- ^ a proxy for the collection to test+                         -> Gen (Element collection)+                            -- ^ a generator to generate elements for the collection+                         -> Test+testCollectionProperties proxy genElement = Group "Collection"+    [ Property "null mempty" $ (null $ fromListP proxy []) === True+    , Property "null . getNonEmpty" $ withNonEmptyElements $ \els ->+          (null $ fromListP proxy $ getNonEmpty els) === False+    , Property "length" $ withElements $ \l -> (length $ fromListP proxy l) === length l+    , Property "elem" $ withListAndElement $ \(l,e) -> elem e (fromListP proxy l) === elem e l+    , Property "notElem" $ withListAndElement $ \(l,e) -> notElem e (fromListP proxy l) === notElem e l+    , Property "minimum" $ withNonEmptyElements $ \els -> minimum (fromListNonEmptyP proxy els) === minimum els+    , Property "maximum" $ withNonEmptyElements $ \els -> maximum (fromListNonEmptyP proxy els) === maximum els+    , Property "all" $ withListAndElement $ \(l, e) ->+        (all (/= e) (fromListP proxy l) === all (/= e) l) `propertyAnd`+        (all (== e) (fromListP proxy l) === all (== e) l)+    , Property "any" $ withListAndElement $ \(l, e) ->+        (any (/= e) (fromListP proxy l) === any (/= e) l) `propertyAnd`+        (any (== e) (fromListP proxy l) === any (== e) l)+    ]+  where+    withElements f = forAll (generateListOfElement genElement) f+    withListAndElement = forAll ((,) <$> generateListOfElement genElement <*> genElement)+    withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f++testSequentialProperties :: forall collection+                          . ( Sequential collection+                            , Eq collection, Eq (Element collection)+                            , Ord collection, Ord (Element collection)+                            , Show collection, Show (Element collection)+                            )+                         => Proxy collection+                         -> Gen (Element collection)+                         -> Test+testSequentialProperties proxy genElement = Group "Sequential"+    [ Property "take" $ withElements2 $ \(l, n) -> toList (take n $ fromListP proxy l) === (take n) l+    , Property "drop" $ withElements2 $ \(l, n) -> toList (drop n $ fromListP proxy l) === (drop n) l+    , Property "splitAt" $ withElements2 $ \(l, n) -> toList2 (splitAt n $ fromListP proxy l) === (splitAt n) l+    , Property "revTake" $ withElements2 $ \(l, n) -> toList (revTake n $ fromListP proxy l) === (revTake n) l+    , Property "revDrop" $ withElements2 $ \(l, n) -> toList (revDrop n $ fromListP proxy l) === (revDrop n) l+    , Property "revSplitAt" $ withElements2 $ \(l, n) -> toList2 (revSplitAt n $ fromListP proxy l) === (revSplitAt n) l+    , Property "break" $ withElements2E $ \(l, c) -> toList2 (break (== c) $ fromListP proxy l) === (break (== c)) l+    , Property "breakElem" $ withElements2E $ \(l, c) -> toList2 (breakElem c $ fromListP proxy l) === (breakElem c) l+    , Property "span" $ withElements2E $ \(l, c) -> toList2 (span (== c) $ fromListP proxy l) === (span (== c)) l+    , Property "filter" $ withElements2E $ \(l, c) -> toList (filter (== c) $ fromListP proxy l) === (filter (== c)) l+    , Property "partition" $ withElements2E $ \(l, c) -> toList2 (partition (== c) $ fromListP proxy l) === (partition (== c)) l+    , Property "snoc" $ withElements2E $ \(l, c) -> toList (snoc (fromListP proxy l) c) === (l <> [c])+    , Property "cons" $ withElements2E $ \(l, c) -> toList (cons c (fromListP proxy l)) === (c : l)+    , Property "unsnoc" $ withElements $ \l -> fmap toListFirst (unsnoc (fromListP proxy l)) === unsnoc l+    , Property "uncons" $ withElements $ \l -> fmap toListSecond (uncons (fromListP proxy l)) === uncons l+    , Property "head" $ withNonEmptyElements $ \els -> head (fromListNonEmptyP proxy els) === head els+    , Property "last" $ withNonEmptyElements $ \els -> last (fromListNonEmptyP proxy els) === last els+    , Property "tail" $ withNonEmptyElements $ \els -> toList (tail $ fromListNonEmptyP proxy els) === tail els+    , Property "init" $ withNonEmptyElements $ \els -> toList (init $ fromListNonEmptyP proxy els) === init els+    , Property "splitOn" $ withElements2E $ \(l, ch) ->+         fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l+    , testSplitOn proxy (\_ -> True) mempty+    , Property "intercalate c (splitOn (c ==) col) == col" $ withElements2E $ \(c, ch) ->+        intercalate [ch] (splitOn (== ch) c) === c+    , Property "intercalate c (splitOn (c ==) (col ++ [c]) == (col ++ [c])" $ withElements2E $ \(c, ch) ->+        intercalate [ch] (splitOn (== ch) $ snoc c ch) === (snoc c ch)+    , Property "intercalate c (splitOn (c ==) (col ++ [c,c]) == (col ++ [c,c])" $ withElements2E $ \(c, ch) ->+        intercalate [ch] (splitOn (== ch) $ snoc (snoc c ch) ch) === (snoc (snoc c ch) ch)+    , Property "intersperse" $ withElements2E $ \(l, c) ->+        toList (intersperse c (fromListP proxy l)) === intersperse c l+    , Property "intercalate" $ withElements2E $ \(l, c) ->+        let ls = Prelude.replicate 5 l+            cs = Prelude.replicate 5 c+        in toList (intercalate (fromListP proxy cs) (fromListP proxy <$> ls)) === intercalate cs ls+    , Property "sortBy" $ withElements $ \l ->+        (sortBy compare $ fromListP proxy l) === fromListP proxy (sortBy compare l)+    , Property "reverse" $ withElements $ \l ->+        (reverse $ fromListP proxy l) === fromListP proxy (reverse l)+    -- stress slicing+    , Property "take . take" $ withElements3 $ \(l, n1, n2) -> toList (take n2 $ take n1 $ fromListP proxy l) === (take n2 $ take n1 l)+    , Property "drop . take" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ take n1 $ fromListP proxy l) === (drop n2 $ take n1 l)+    , Property "drop . drop" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ drop n1 $ fromListP proxy l) === (drop n2 $ drop n1 l)+    , Property "drop . take" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ take n1 $ fromListP proxy l) === (drop n2 $ take n1 l)+    , Property "second take . splitAt" $ withElements3 $ \(l, n1, n2) ->+        (toList2 $ (second (take n1) . splitAt n2) $ fromListP proxy l) === (second (take n1) . splitAt n2) l+    , Property "splitAt == (take, drop)" $ withCollection2 $ \(col, n) ->+        splitAt n col === (take n col, drop n col)+    , Property "revSplitAt == (revTake, revDrop)" $ withCollection2 $ \(col, n) ->+        revSplitAt n col === (revTake n col, revDrop n col)+    , Group "isSuffixOf"+        [ Property "collection + sub" $ withElements2 $ \(l1, n) ->+            let c1 = fromListP proxy l1 in isSuffixOf (revTake n c1) c1 === isSuffixOf (revTake n l1) l1+        , Property "2 collections" $ with2Elements $ \(l1, l2) -> isSuffixOf (fromListP proxy l1) (fromListP proxy l2) === isSuffixOf l1 l2+        , Property "collection + empty" $ withElements $ \l1 ->+            isSuffixOf (fromListP proxy []) (fromListP proxy l1) === isSuffixOf [] l1+        ]+    , Group "isPrefixOf"+        [ Property "collection + sub" $ withElements2 $ \(l1, n) ->+            let c1 = fromListP proxy l1 in isPrefixOf (take n c1) c1 === isPrefixOf (take n l1) l1+        , Property "2 collections" $ with2Elements $ \(l1, l2) -> isPrefixOf (fromListP proxy l1) (fromListP proxy l2) === isPrefixOf l1 l2+        , Property "collection + empty" $ withElements $ \l1 ->+            isPrefixOf (fromListP proxy []) (fromListP proxy l1) === isPrefixOf [] l1+        ]+    ]+{-+    , testProperty "imap" $ \(CharMap (LUString u) i) ->+        (imap (addChar i) (fromList u) :: String) `assertEq` fromList (Prelude.map (addChar i) u)+    ]+-}+  where+    toList2 (x,y) = (toList x, toList y)+    toListFirst (x,y) = (toList x, y)+    toListSecond (x,y) = (x, toList y)+    withElements f = forAll (generateListOfElement genElement) f+    with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f+    withElements2 f = forAll ((,) <$> generateListOfElement genElement <*> arbitrary) f+    withElements3 f = forAll ((,,) <$> generateListOfElement genElement <*> arbitrary <*> arbitrary) f+    withElements2E f = forAll ((,) <$> generateListOfElement genElement <*> genElement) f+    withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f+    withCollection2 f = forAll ((,) <$> (fromListP proxy <$> generateListOfElement genElement) <*> arbitrary) f++    testSplitOn :: ( Sequential a+                   , Show a, Show (Element a)+                   , Eq (Element a)+                   , Eq a, Ord a, Ord (Item a), Show a+                   )+                => Proxy a -> (Element a -> Bool) -> a+                -> Test+    testSplitOn _ predicate col = Property "splitOn (const True) mempty == [mempty]" $+      (splitOn predicate col) === [col]

@@ -24,27 +24,7 @@  testArrayRefs :: TestTree testArrayRefs = testGroup "Array"-    [ testGroup "Unboxed"-        [ testCollection "UArray(W8)"  (Proxy :: Proxy (UArray Word8))  arbitrary-        , testCollection "UArray(W16)" (Proxy :: Proxy (UArray Word16)) arbitrary-        , testCollection "UArray(W32)" (Proxy :: Proxy (UArray Word32)) arbitrary-        , testCollection "UArray(W64)" (Proxy :: Proxy (UArray Word64)) arbitrary-        , testCollection "UArray(I8)"  (Proxy :: Proxy (UArray Int8))   arbitrary-        , testCollection "UArray(I16)" (Proxy :: Proxy (UArray Int16))  arbitrary-        , testCollection "UArray(I32)" (Proxy :: Proxy (UArray Int32))  arbitrary-        , testCollection "UArray(I64)" (Proxy :: Proxy (UArray Int64))  arbitrary-        , testCollection "UArray(F32)" (Proxy :: Proxy (UArray Float))  arbitrary-        , 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 "Unboxed-Foreign"         [ testGroup "UArray(W8)"  (testUnboxedForeign (Proxy :: Proxy (UArray Word8))  arbitrary)         , testGroup "UArray(W16)" (testUnboxedForeign (Proxy :: Proxy (UArray Word16)) arbitrary)         , testGroup "UArray(W32)" (testUnboxedForeign (Proxy :: Proxy (UArray Word32)) arbitrary)@@ -63,29 +43,6 @@         , 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-        , testCollection "Array(W16)" (Proxy :: Proxy (Array Word16)) arbitrary-        , testCollection "Array(W32)" (Proxy :: Proxy (Array Word32)) arbitrary-        , testCollection "Array(W64)" (Proxy :: Proxy (Array Word64)) arbitrary-        , testCollection "Array(I8)"  (Proxy :: Proxy (Array Int8))   arbitrary-        , testCollection "Array(I16)" (Proxy :: Proxy (Array Int16))  arbitrary-        , testCollection "Array(I32)" (Proxy :: Proxy (Array Int32))  arbitrary-        , testCollection "Array(I64)" (Proxy :: Proxy (Array Int64))  arbitrary-        , testCollection "Array(F32)" (Proxy :: Proxy (Array Float))  arbitrary-        , testCollection "Array(F64)" (Proxy :: Proxy (Array Double)) arbitrary-        , 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(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)         ]     ] 

@@ -25,25 +25,7 @@  testChunkedUArrayRefs :: TestTree testChunkedUArrayRefs = testGroup "ChunkedArray"-    [ testGroup "Unboxed"-        [ testCollection "ChunkedUArray(W8)"  (Proxy :: Proxy (ChunkedUArray Word8))  arbitrary-        , testCollection "ChunkedUArray(W16)" (Proxy :: Proxy (ChunkedUArray Word16)) arbitrary-        , testCollection "ChunkedUArray(W32)" (Proxy :: Proxy (ChunkedUArray Word32)) arbitrary-        , testCollection "ChunkedUArray(W64)" (Proxy :: Proxy (ChunkedUArray Word64)) arbitrary-        , testCollection "ChunkedUArray(I8)"  (Proxy :: Proxy (ChunkedUArray Int8))   arbitrary-        , testCollection "ChunkedUArray(I16)" (Proxy :: Proxy (ChunkedUArray Int16))  arbitrary-        , testCollection "ChunkedUArray(I32)" (Proxy :: Proxy (ChunkedUArray Int32))  arbitrary-        , 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 "Unboxed-Foreign"         [ testGroup "UArray(W8)"  (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word8))  arbitrary)         , testGroup "UArray(W16)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word16)) arbitrary)         , testGroup "UArray(W32)" (testUnboxedForeign (Proxy :: Proxy (ChunkedUArray Word32)) arbitrary)@@ -60,27 +42,6 @@         , 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-        , testCollection "Array(W16)" (Proxy :: Proxy (Array Word16)) arbitrary-        , testCollection "Array(W32)" (Proxy :: Proxy (Array Word32)) arbitrary-        , testCollection "Array(W64)" (Proxy :: Proxy (Array Word64)) arbitrary-        , testCollection "Array(I8)"  (Proxy :: Proxy (Array Int8))   arbitrary-        , testCollection "Array(I16)" (Proxy :: Proxy (Array Int16))  arbitrary-        , testCollection "Array(I32)" (Proxy :: Proxy (Array Int32))  arbitrary-        , testCollection "Array(I64)" (Proxy :: Proxy (Array Int64))  arbitrary-        , testCollection "Array(F32)" (Proxy :: Proxy (Array Float))  arbitrary-        , testCollection "Array(F64)" (Proxy :: Proxy (Array Double)) arbitrary-        , 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)         ]     ]