diff --git a/Foundation.hs b/Foundation.hs --- a/Foundation.hs +++ b/Foundation.hs @@ -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 diff --git a/Foundation/Array/Boxed.hs b/Foundation/Array/Boxed.hs --- a/Foundation/Array/Boxed.hs +++ b/Foundation/Array/Boxed.hs @@ -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) diff --git a/Foundation/Array/Chunked/Unboxed.hs b/Foundation/Array/Chunked/Unboxed.hs --- a/Foundation/Array/Chunked/Unboxed.hs +++ b/Foundation/Array/Chunked/Unboxed.hs @@ -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 diff --git a/Foundation/Array/Internal.hs b/Foundation/Array/Internal.hs --- a/Foundation/Array/Internal.hs +++ b/Foundation/Array/Internal.hs @@ -17,6 +17,11 @@ , withPtr , recast , toHexadecimal + -- * Mutable facilities + , new + , newPinned + , withMutablePtr ) where import Foundation.Array.Unboxed +import Foundation.Array.Unboxed.Mutable diff --git a/Foundation/Array/Unboxed.hs b/Foundation/Array/Unboxed.hs --- a/Foundation/Array/Unboxed.hs +++ b/Foundation/Array/Unboxed.hs @@ -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) diff --git a/Foundation/Array/Unboxed/Mutable.hs b/Foundation/Array/Unboxed/Mutable.hs --- a/Foundation/Array/Unboxed/Mutable.hs +++ b/Foundation/Array/Unboxed/Mutable.hs @@ -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. -- diff --git a/Foundation/Check.hs b/Foundation/Check.hs --- a/Foundation/Check.hs +++ b/Foundation/Check.hs @@ -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"] diff --git a/Foundation/Check/Arbitrary.hs b/Foundation/Check/Arbitrary.hs --- a/Foundation/Check/Arbitrary.hs +++ b/Foundation/Check/Arbitrary.hs @@ -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) diff --git a/Foundation/Conduit.hs b/Foundation/Conduit.hs --- a/Foundation/Conduit.hs +++ b/Foundation/Conduit.hs @@ -3,6 +3,7 @@ , ResourceT , ZipSink (..) , await + , awaitForever , yield , yieldOr , leftover diff --git a/Foundation/Conduit/Internal.hs b/Foundation/Conduit/Internal.hs --- a/Foundation/Conduit/Internal.hs +++ b/Foundation/Conduit/Internal.hs @@ -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 () diff --git a/Foundation/Conduit/Textual.hs b/Foundation/Conduit/Textual.hs new file mode 100644 --- /dev/null +++ b/Foundation/Conduit/Textual.hs @@ -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 diff --git a/Foundation/IO.hs b/Foundation/IO.hs --- a/Foundation/IO.hs +++ b/Foundation/IO.hs @@ -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 diff --git a/Foundation/IO/Terminal.hs b/Foundation/IO/Terminal.hs --- a/Foundation/IO/Terminal.hs +++ b/Foundation/IO/Terminal.hs @@ -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 () diff --git a/Foundation/Internal/NumLiteral.hs b/Foundation/Internal/NumLiteral.hs --- a/Foundation/Internal/NumLiteral.hs +++ b/Foundation/Internal/NumLiteral.hs @@ -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 diff --git a/Foundation/List/DList.hs b/Foundation/List/DList.hs new file mode 100644 --- /dev/null +++ b/Foundation/List/DList.hs @@ -0,0 +1,88 @@ +-- | +-- Module : Foundation.List.DList +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- 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 diff --git a/Foundation/Monad/Reader.hs b/Foundation/Monad/Reader.hs --- a/Foundation/Monad/Reader.hs +++ b/Foundation/Monad/Reader.hs @@ -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 diff --git a/Foundation/Monad/State.hs b/Foundation/Monad/State.hs --- a/Foundation/Monad/State.hs +++ b/Foundation/Monad/State.hs @@ -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 diff --git a/Foundation/Network/IPv4.hs b/Foundation/Network/IPv4.hs --- a/Foundation/Network/IPv4.hs +++ b/Foundation/Network/IPv4.hs @@ -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 diff --git a/Foundation/Network/IPv6.hs b/Foundation/Network/IPv6.hs --- a/Foundation/Network/IPv6.hs +++ b/Foundation/Network/IPv6.hs @@ -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 diff --git a/Foundation/Primitive.hs b/Foundation/Primitive.hs --- a/Foundation/Primitive.hs +++ b/Foundation/Primitive.hs @@ -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 diff --git a/Foundation/Primitive/Floating.hs b/Foundation/Primitive/Floating.hs --- a/Foundation/Primitive/Floating.hs +++ b/Foundation/Primitive/Floating.hs @@ -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 diff --git a/Foundation/Primitive/NormalForm.hs b/Foundation/Primitive/NormalForm.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/NormalForm.hs @@ -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 diff --git a/Foundation/String/Read.hs b/Foundation/String/Read.hs --- a/Foundation/String/Read.hs +++ b/Foundation/String/Read.hs @@ -1,7 +1,9 @@ module Foundation.String.Read ( readInteger + , readIntegral , readNatural , readDouble + , readRational , readFloatingExact ) where diff --git a/Foundation/String/UTF8.hs b/Foundation/String/UTF8.hs --- a/Foundation/String/UTF8.hs +++ b/Foundation/String/UTF8.hs @@ -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 #) #-} diff --git a/Foundation/System/Bindings/Linux.hsc b/Foundation/System/Bindings/Linux.hsc --- a/Foundation/System/Bindings/Linux.hsc +++ b/Foundation/System/Bindings/Linux.hsc @@ -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 diff --git a/Foundation/System/Bindings/Posix.hsc b/Foundation/System/Bindings/Posix.hsc --- a/Foundation/System/Bindings/Posix.hsc +++ b/Foundation/System/Bindings/Posix.hsc @@ -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 diff --git a/Foundation/Tuple.hs b/Foundation/Tuple.hs --- a/Foundation/Tuple.hs +++ b/Foundation/Tuple.hs @@ -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 diff --git a/Foundation/UUID.hs b/Foundation/UUID.hs --- a/Foundation/UUID.hs +++ b/Foundation/UUID.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/benchs/Fake/ByteString.hs b/benchs/Fake/ByteString.hs --- a/benchs/Fake/ByteString.hs +++ b/benchs/Fake/ByteString.hs @@ -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 diff --git a/benchs/Fake/Text.hs b/benchs/Fake/Text.hs --- a/benchs/Fake/Text.hs +++ b/benchs/Fake/Text.hs @@ -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 diff --git a/benchs/Main.hs b/benchs/Main.hs --- a/benchs/Main.hs +++ b/benchs/Main.hs @@ -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" diff --git a/cbits/foundation_random.c b/cbits/foundation_random.c --- a/cbits/foundation_random.c +++ b/cbits/foundation_random.c @@ -9,6 +9,7 @@ #if defined(FOUNDATION_SYSTEM_LINUX) #include +#include #include #include #define _GNU_SOURCE diff --git a/foundation.cabal b/foundation.cabal --- a/foundation.cabal +++ b/foundation.cabal @@ -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 diff --git a/tests/Checks.hs b/tests/Checks.hs --- a/tests/Checks.hs +++ b/tests/Checks.hs @@ -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) + ] + ] ] diff --git a/tests/Test/Checks/Property/Collection.hs b/tests/Test/Checks/Property/Collection.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Checks/Property/Collection.hs @@ -0,0 +1,300 @@ +-- | +-- Module : Test.Checks.Property.Collection +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- 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] diff --git a/tests/Test/Foundation/Array.hs b/tests/Test/Foundation/Array.hs --- a/tests/Test/Foundation/Array.hs +++ b/tests/Test/Foundation/Array.hs @@ -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) ] ] diff --git a/tests/Test/Foundation/ChunkedUArray.hs b/tests/Test/Foundation/ChunkedUArray.hs --- a/tests/Test/Foundation/ChunkedUArray.hs +++ b/tests/Test/Foundation/ChunkedUArray.hs @@ -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) ] ]