diff --git a/Foundation/Array/Boxed.hs b/Foundation/Array/Boxed.hs --- a/Foundation/Array/Boxed.hs +++ b/Foundation/Array/Boxed.hs @@ -425,7 +425,7 @@ splitOn :: (ty -> Bool) -> Array ty -> [Array ty] splitOn predicate vec - | len == Size 0 = [] + | len == Size 0 = [mempty] | otherwise = loop (Offset 0) (Offset 0) where !len = lengthSize vec 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 @@ -116,13 +116,7 @@ A.unsafeFreeze a vToList :: PrimType ty => ChunkedUArray ty -> [ty] -vToList (ChunkedUArray a) = loop (C.length a) 0 mempty - where - -- TODO: Rewrite this to use something like a `DList` - -- to avoid the expensive `mappend`. - loop len !acc l = case acc >= len of - True -> l - False -> loop len (acc+1) ((toList (A.unsafeIndex a acc)) <> l) +vToList (ChunkedUArray a) = mconcat $ toList $ toList <$> a null :: PrimType ty => ChunkedUArray ty -> Bool null (ChunkedUArray array) = @@ -314,8 +308,8 @@ uncons :: PrimType ty => ChunkedUArray ty -> Maybe (ty, ChunkedUArray ty) uncons v = second fromList <$> (C.uncons $ toList v) -snoc :: PrimType ty => ChunkedUArray ty -> ty -> ChunkedUArray ty -snoc (ChunkedUArray inner) el = ChunkedUArray $ runST $ do +cons :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty +cons el (ChunkedUArray inner) = ChunkedUArray $ runST $ do let newLen = (Size $ C.length inner + 1) newArray <- A.new newLen let single = fromList [el] @@ -323,8 +317,8 @@ A.unsafeCopyAtRO newArray (Offset 1) inner (Offset 0) (Size $ C.length inner) A.unsafeFreeze newArray -cons :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty -cons el (ChunkedUArray inner) = ChunkedUArray $ runST $ do +snoc :: PrimType ty => ChunkedUArray ty -> ty -> ChunkedUArray ty +snoc (ChunkedUArray inner) el = ChunkedUArray $ runST $ do newArray <- A.new (Size $ C.length inner + 1) let single = fromList [el] A.unsafeCopyAtRO newArray (Offset 0) inner (Offset 0) (Size $ C.length inner) diff --git a/Foundation/Array/Unboxed.hs b/Foundation/Array/Unboxed.hs --- a/Foundation/Array/Unboxed.hs +++ b/Foundation/Array/Unboxed.hs @@ -578,8 +578,8 @@ | k == end = (# r, empty #) | k == start = (# empty, r #) | otherwise = - (# UVecBA start (offsetAsSize k) pinst ba - , UVecBA (start `offsetPlusE` (offsetAsSize k)) (len - offsetAsSize k) pinst ba + (# UVecBA start (offsetAsSize k - offsetAsSize start) pinst ba + , UVecBA k (len - (offsetAsSize k - offsetAsSize start)) pinst ba #) where !end = start `offsetPlusE` len @@ -590,8 +590,9 @@ splitElem !ty r@(UVecAddr start len fptr) | k == end = (# r, empty #) | otherwise = - (# UVecAddr start (offsetAsSize k) fptr - , UVecAddr (start `offsetPlusE` offsetAsSize k) (len - offsetAsSize k) fptr #) + (# UVecAddr start (offsetAsSize k - offsetAsSize start) fptr + , UVecAddr k (len - (offsetAsSize k - offsetAsSize start)) fptr + #) where !(Ptr addr) = withFinalPtrNoTouch fptr id !end = start `offsetPlusE` len @@ -614,7 +615,7 @@ splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty] splitOn xpredicate ivec - | len == 0 = [] + | len == 0 = [mempty] | otherwise = runST $ unsafeIndexer ivec (go ivec xpredicate) where !len = length ivec @@ -923,7 +924,7 @@ | sIdx == endOfs = return () | otherwise = do let !(W8# !w) = getAt sIdx - (# wHi, wLo #) = Base16.convertByte w + (# wHi, wLo #) = Base16.unsafeConvertByte w unsafeWrite ma dIdx (W8# wHi) unsafeWrite ma (dIdx+1) (W8# wLo) loop (dIdx + 2) (sIdx+1) diff --git a/Foundation/Check.hs b/Foundation/Check.hs new file mode 100644 --- /dev/null +++ b/Foundation/Check.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module Foundation.Check + ( Gen + , Arbitrary(..) + -- test + , Test(..) + , testName + -- * Property + , Property(..) + , IsProperty(..) + , (===) + -- * As Program + , defaultMain + ) where + +import Foundation.Internal.Base +import Foundation.Collection +import Foundation.Numerical +import Foundation.String +import Foundation.IO.Terminal +import Foundation.Check.Gen +import Foundation.Check.Arbitrary +import Foundation.Check.Property +import Foundation.Monad +import Control.Exception (evaluate, SomeException) +import System.Exit + +-- different type of tests +data Test where + -- Unit test + Unit :: String -> IO () -> Test + -- Property test + Property :: IsProperty prop => String -> prop -> Test + -- Multiples tests grouped together + Group :: String -> [Test] -> Test + +-- | Name of a test +testName :: Test -> String +testName (Unit s _) = s +testName (Property s _) = s +testName (Group s _) = s + +data Context = Context + { contextLevel :: !Word + , contextGroups :: [String] + , contextSeed :: !Word64 + } + +appendContext :: String -> Context -> Context +appendContext s ctx = ctx + { contextLevel = 1 + contextLevel ctx + , contextGroups = s : contextGroups ctx + } + +data PropertyResult = + PropertySuccess + | PropertyFailed String + deriving (Show,Eq) + +data TestResult = + PropertyResult String Word64 PropertyResult + | GroupResult String HasFailures [TestResult] + deriving (Show) + +type HasFailures = Word + +nbFail :: TestResult -> HasFailures +nbFail (PropertyResult _ _ (PropertyFailed _)) = 1 +nbFail (PropertyResult _ _ PropertySuccess) = 0 +nbFail (GroupResult _ t _) = t + +runProp :: Context -> String -> Property -> IO TestResult +runProp ctx s prop = do + (\(e, i) -> PropertyResult s i e) <$> iterProp 0 + where + nbTests = 100 + iterProp :: Word64 -> IO (PropertyResult, Word64) + iterProp i + | i == nbTests = return (PropertySuccess, nbTests) + | otherwise = do + r <- toResult i + case r of + PropertyFailed e -> return (PropertyFailed e, i) + PropertySuccess -> iterProp (i+1) + toResult :: Word64 -> IO PropertyResult + toResult it = + (propertyToResult <$> evaluate (runGen (unProp prop) (rngIt it) params)) + `catch` (\(e :: SomeException) -> return $ PropertyFailed (fromList $ show e)) + + propertyToResult False = PropertyFailed "property failed" + propertyToResult True = PropertySuccess + + !rngIt = genRng (contextSeed ctx) (s : contextGroups ctx) + !params = GenParams {} + +-- | Run tests +defaultMain :: Test -> IO () +defaultMain test = do + -- parse arguments + --let arguments = [ "seed", "j" ] + let seed = 10 + + let context = Context { contextLevel = 0 + , contextGroups = [] + , contextSeed = seed + } + + printHeader context + tr <- runTest context test + if nbFail tr > 0 + then putStrLn (fromList (show $ nbFail tr) <> " failure(s)") >> exitFailure + else putStrLn "Success" >> exitSuccess + where + printHeader ctx = do + putStrLn ("seed: " <> fromList (show (contextSeed ctx))) -- TODO hexadecimal + + runTest :: Context -> Test -> IO TestResult + runTest ctx (Group s l) = do + putStrLn s + results <- mapM (runTest (appendContext s ctx)) l + return $ GroupResult s (foldl' (+) 0 $ fmap nbFail results) results + runTest ctx (Property name prop) = do + v <- runProp ctx name (property prop) + putStrLn $ fromList (show v) + return v + + runTest _ (Unit _ _) = do + error "not implemented" diff --git a/Foundation/Check/Arbitrary.hs b/Foundation/Check/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Foundation/Check/Arbitrary.hs @@ -0,0 +1,60 @@ +module Foundation.Check.Arbitrary + ( Arbitrary(..) + ) where + +import Foundation.Internal.Base +import Foundation.Internal.Natural +import Foundation.Check.Gen +import Foundation.Random + +-- | How to generate an arbitrary value for 'a' +class Arbitrary a where + arbitrary :: Gen a + +arbitraryBounded :: Bounded b => Gen b +arbitraryBounded = undefined + +instance Arbitrary Int where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Integer where + arbitrary = undefined +instance Arbitrary Natural where + arbitrary = undefined +instance Arbitrary Word64 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Word32 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Word16 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Word8 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Int64 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Int32 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Int16 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Int8 where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Char where + arbitrary = genWithRng getRandomPrimType +instance Arbitrary Bool where + arbitrary = undefined -- arbitrary + +--instance Arbitrary a => Arbitrary (Maybe a) where + +instance (Arbitrary a, Arbitrary b) + => Arbitrary (a,b) where + arbitrary = (,) <$> arbitrary <*> arbitrary +instance (Arbitrary a, Arbitrary b, Arbitrary c) + => Arbitrary (a,b,c) where + arbitrary = (,,) <$> arbitrary <*> arbitrary <*> arbitrary +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) + => Arbitrary (a,b,c,d) where + arbitrary = (,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) + => Arbitrary (a,b,c,d,e) where + arbitrary = (,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) + => Arbitrary (a,b,c,d,e,f) where + arbitrary = (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/Foundation/Check/Gen.hs b/Foundation/Check/Gen.hs new file mode 100644 --- /dev/null +++ b/Foundation/Check/Gen.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module Foundation.Check.Gen + ( Gen + , runGen + , GenParams(..) + , genRng + , genWithRng + ) where + +import Foundation.Internal.Base +import Foundation.Collection +import Foundation.Random +import Foundation.String +import Foundation.Numerical +import Foundation.Hashing.SipHash +import Foundation.Hashing.Hasher +import qualified Foundation.Array.Unboxed as A + +data GenParams = GenParams + { + } + +newtype GenRng = GenRng RNGv1 + +type GenSeed = Word64 + +genRng :: GenSeed -> [String] -> (Word64 -> GenRng) +genRng seed groups = \iteration -> genRngNewNoFail $ A.unsafeRecast $ fromList [w1,w2,w3,iteration] + where + w1 = rngSeed + w2 = rngSeed * 2 + w3 = rngSeed * 4 + + (SipHash rngSeed) = hashEnd $ hashMixBytes hashData iHashState + hashData = toBytes UTF8 $ intercalate "::" (reverse groups) + iHashState :: Sip1_3 + iHashState = hashNewParam (SipKey seed 0x12345678) + +genRngNewNoFail :: A.UArray Word8 -> GenRng +genRngNewNoFail = maybe (error "impossible") GenRng . randomNewFrom + +genGenerator :: GenRng -> (GenRng, GenRng) +genGenerator (GenRng rng) = + let (newSeed, rngNext) = randomGenerate 32 rng + in (genRngNewNoFail newSeed, GenRng rngNext) + +-- | Generator monad +newtype Gen a = Gen { runGen :: GenRng -> GenParams -> a } + +instance Functor Gen where + fmap f g = Gen (\rng params -> f (runGen g rng params)) + +instance Applicative Gen where + pure a = Gen (\_ _ -> a) + fab <*> fa = Gen $ \rng params -> + let (r1,r2) = genGenerator rng + ab = runGen fab r1 params + a = runGen fa r2 params + in ab a + +instance Monad Gen where + return a = Gen (\_ _ -> a) + ma >>= mb = Gen $ \rng params -> + let (r1,r2) = genGenerator rng + a = runGen ma r1 params + in runGen (mb a) r2 params + +genWithRng :: forall a . (forall randomly . MonadRandom randomly => randomly a) -> Gen a +genWithRng f = Gen $ \(GenRng rng) _ -> + let (a, _) = withRandomGenerator rng f in a diff --git a/Foundation/Check/Property.hs b/Foundation/Check/Property.hs new file mode 100644 --- /dev/null +++ b/Foundation/Check/Property.hs @@ -0,0 +1,33 @@ +module Foundation.Check.Property + ( Property(..) + , IsProperty + , property + -- * Properties + , forAll + , (===) + ) where + +import Foundation.Internal.Base +import Foundation.Check.Gen +import Foundation.Check.Arbitrary + +class IsProperty p where + property :: p -> Property + +instance IsProperty Bool where + property b = Prop (pure b) +instance IsProperty Property where + property p = p -- (Prop result) = Prop . return $ result +instance IsProperty prop => IsProperty (Gen prop) where + property mp = Prop (mp >>= \p -> unProp (property p)) +instance (Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where + property p = forAll arbitrary p + +data Property = Prop { unProp :: Gen Bool } + +forAll :: IsProperty prop => Gen a -> (a -> prop) -> Property +forAll generator tst = Prop (generator >>= \a -> unProp (property (tst a))) + +(===) :: Eq a => a -> a -> Property +(===) a b = Prop (pure (a == b)) +infix 4 === diff --git a/Foundation/Class/Storable.hs b/Foundation/Class/Storable.hs --- a/Foundation/Class/Storable.hs +++ b/Foundation/Class/Storable.hs @@ -10,13 +10,21 @@ -- {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Foundation.Class.Storable ( Storable(..) , StorableFixed(..) + -- * Ptr , Ptr, plusPtr, castPtr + -- * offset based helper , peekOff, pokeOff + -- * Collection + , peekArray + , peekArrayEndedBy + , pokeArray + , pokeArrayEndedBy ) where import GHC.Types (Double, Float) @@ -29,6 +37,8 @@ import Foundation.Internal.Base import Foundation.Internal.Types import Foundation.Internal.Proxy +import Foundation.Collection +import Foundation.Collection.Buildable (builderLift) import Foundation.Primitive.Types import Foundation.Primitive.Endianness import Foundation.Numerical @@ -61,6 +71,42 @@ -- | like `poke` but at a given offset. pokeOff :: StorableFixed a => Ptr a -> Offset a -> a -> IO () pokeOff ptr off = poke (ptr `plusPtr` offsetAsSize off) + +peekArray :: (Buildable col, StorableFixed (Element col)) + => Size (Element col) -> Ptr (Element col) -> IO col +peekArray (Size s) = build 64 . builder 0 + where + builder off ptr + | off == s = return () + | otherwise = do + v <- builderLift (peekOff ptr (Offset off)) + append v + builder (off + 1) ptr + +peekArrayEndedBy :: (Buildable col, StorableFixed (Element col), Eq (Element col), Show (Element col)) + => Element col -> Ptr (Element col) -> IO col +peekArrayEndedBy term = build 64 . builder 0 + where + builder off ptr = do + v <- builderLift $ peekOff ptr off + if term == v + then return () + else append v >> builder (off + (Offset 1)) ptr + +pokeArray :: (Sequential col, StorableFixed (Element col)) + => Ptr (Element col) -> col -> IO () +pokeArray ptr arr = + forM_ (z [0..] arr) $ \(i, e) -> + pokeOff ptr (Offset i) e + where + z :: (Sequential col, Collection col) => [Int] -> col -> [(Int, Element col)] + z = zip + +pokeArrayEndedBy :: (Sequential col, StorableFixed (Element col)) + => Element col -> Ptr (Element col) -> col -> IO () +pokeArrayEndedBy term ptr col = do + pokeArray ptr col + pokeOff ptr (Offset $ length col) term instance Storable CChar where peek (Ptr addr) = primAddrRead addr (Offset 0) diff --git a/Foundation/Collection.hs b/Foundation/Collection.hs --- a/Foundation/Collection.hs +++ b/Foundation/Collection.hs @@ -15,6 +15,11 @@ , Element , InnerFunctor(..) , Foldable(..) + , Mappable(..) + , traverse_ + , mapM_ + , forM + , forM_ , Collection(..) , NonEmpty , getNonEmpty @@ -40,5 +45,6 @@ import Foundation.Collection.Mutable import Foundation.Collection.Collection import Foundation.Collection.Sequential +import Foundation.Collection.Mappable import Foundation.Collection.Zippable import Foundation.Collection.Copy diff --git a/Foundation/Collection/Buildable.hs b/Foundation/Collection/Buildable.hs --- a/Foundation/Collection/Buildable.hs +++ b/Foundation/Collection/Buildable.hs @@ -11,6 +11,7 @@ ( Buildable(..) , Builder(..) , BuildingState(..) + , builderLift ) where import Foundation.Array.Unboxed @@ -21,6 +22,7 @@ import Foundation.Internal.Base import Foundation.Primitive.Monad import Foundation.Boot.Builder +import Foundation.Internal.MonadTrans -- $setup -- >>> import Control.Monad.ST @@ -53,6 +55,13 @@ => Int -- ^ Size of a chunk -> Builder col (Mutable col) (Step col) prim () -> prim col + +builderLift :: (Buildable c, PrimMonad prim) + => prim a + -> Builder c (Mutable c) (Step c) prim a +builderLift f = Builder $ State $ \(i, st) -> do + ret <- f + return (ret, (i, st)) instance PrimType ty => Buildable (UArray ty) where type Mutable (UArray ty) = MUArray ty diff --git a/Foundation/Collection/InnerFunctor.hs b/Foundation/Collection/InnerFunctor.hs --- a/Foundation/Collection/InnerFunctor.hs +++ b/Foundation/Collection/InnerFunctor.hs @@ -12,7 +12,7 @@ -- | A monomorphic functor that maps the inner values to values of the same type class InnerFunctor c where imap :: (Element c -> Element c) -> c -> c - default imap :: (Functor f, Element (f a) ~ a, f a ~ c) => (a -> a) -> f a -> f a + default imap :: (Functor f, Element (f a) ~ a, f a ~ c) => (Element c -> Element c) -> c -> c imap = fmap instance InnerFunctor [a] diff --git a/Foundation/Collection/List.hs b/Foundation/Collection/List.hs --- a/Foundation/Collection/List.hs +++ b/Foundation/Collection/List.hs @@ -21,7 +21,7 @@ -- | Simple helper to split a list repeatly when the predicate match wordsWhen :: (x -> Bool) -> [x] -> [[x]] -wordsWhen _ [] = [] +wordsWhen _ [] = [[]] wordsWhen p is = loop is where loop s = diff --git a/Foundation/Collection/Mappable.hs b/Foundation/Collection/Mappable.hs new file mode 100644 --- /dev/null +++ b/Foundation/Collection/Mappable.hs @@ -0,0 +1,104 @@ +-- | +-- Module : Foundation.Primitive.Mappable +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : experimental +-- Portability : portable +-- +-- Class of collection that can be traversed from left to right, +-- performing an action on each element. +-- +module Foundation.Collection.Mappable + ( Mappable(..) + , sequence_ + , traverse_ + , mapM_ + , forM + , forM_ + ) where + +import Foundation.Internal.Base +import qualified Data.Traversable +import Foundation.Array.Boxed (Array) + +-- | Functors representing data structures that can be traversed from +-- left to right. +-- +-- Mostly like base's `Traversable` but applied to collections only. +-- +class Functor collection => Mappable collection where + {-# MINIMAL traverse | sequenceA #-} + + -- | Map each element of a structure to an action, evaluate these actions + -- from left to right, and collect the results. For a version that ignores + -- the results see 'Foundation.Collection.traverse_'. + traverse :: Applicative f => (a -> f b) + -> collection a + -> f (collection b) + traverse f = sequenceA . fmap f + + -- | Evaluate each actions of the given collections, from left to right, + -- and collect the results. For a version that ignores the results, see + -- `Foundation.Collection.sequenceA_` + sequenceA :: Applicative f => collection (f a) + -> f (collection a) + sequenceA = traverse id + + -- | Map each element of the collection to an action, evaluate these actions + -- from left to right, and collect the results. For a version that ignores + -- the results see 'Foundation.Collection.mapM_'. + mapM :: (Applicative m, Monad m) => (a -> m b) -> collection a -> m (collection b) + mapM = traverse + + -- | Evaluate each actions of the given collections, from left to right, + -- and collect the results. For a version that ignores the results, see + -- `Foundation.Collection.sequence_` + sequence :: (Applicative m, Monad m) => collection (m a) -> m (collection a) + sequence = sequenceA + +-- | Map each element of a collection to an action, evaluate these +-- actions from left to right, and ignore the results. For a version +-- that doesn't ignore the results see 'Foundation.Collection.traverse` +traverse_ :: (Mappable col, Applicative f) => (a -> f b) -> col a -> f () +traverse_ f col = traverse f col *> pure () + +-- | Evaluate each action in the collection from left to right, and +-- ignore the results. For a version that doesn't ignore the results +-- see 'Foundation.Collection.sequenceA'. +sequenceA_ :: (Mappable col, Applicative f) => col (f a) -> f () +sequenceA_ col = sequenceA col *> pure () + +-- | Map each element of a collection to a monadic action, evaluate +-- these actions from left to right, and ignore the results. For a +-- version that doesn't ignore the results see +-- 'Foundation.Collection.mapM'. +mapM_ :: (Mappable col, Applicative m, Monad m) => (a -> m b) -> col a -> m () +mapM_ f c = mapM f c *> return () + +-- | Evaluate each monadic action in the collection from left to right, +-- and ignore the results. For a version that doesn't ignore the +-- results see 'Foundation.Collection.sequence'. +sequence_ :: (Mappable col, Applicative m, Monad m) => col (m a) -> m () +sequence_ c = sequence c *> return () + +-- | 'forM' is 'mapM' with its arguments flipped. For a version that +-- ignores the results see 'Foundation.Collection.forM_'. +forM :: (Mappable col, Applicative m, Monad m) => col a -> (a -> m b) -> m (col b) +forM = flip mapM + +-- | 'forM_' is 'mapM_' with its arguments flipped. For a version that +-- doesn't ignore the results see 'Foundation.Collection.forM'. +forM_ :: (Mappable col, Applicative m, Monad m) => col a -> (a -> m b) -> m () +forM_ = flip mapM_ + +---------------------------- +-- Foldable instances +---------------------------- + +instance Mappable [] where + {-# INLINE traverse #-} + traverse = Data.Traversable.traverse + +instance Mappable Array where + -- | TODO: to optimise + traverse f arr = fromList <$> traverse f (toList arr) diff --git a/Foundation/Hashing/FNV.hs b/Foundation/Hashing/FNV.hs --- a/Foundation/Hashing/FNV.hs +++ b/Foundation/Hashing/FNV.hs @@ -80,28 +80,36 @@ instance Hasher FNV1_32 where type HashResult FNV1_32 = FNV1Hash32 + type HashInitParam FNV1_32 = Word hashNew = FNV1_32 0 + hashNewParam w = FNV1_32 w hashEnd (FNV1_32 w) = FNV1Hash32 (Prelude.fromIntegral w) hashMix8 = fnv1_32_Mix8 hashMixBytes = fnv1_32_mixBa instance Hasher FNV1a_32 where type HashResult FNV1a_32 = FNV1Hash32 + type HashInitParam FNV1a_32 = Word hashNew = FNV1a_32 0 + hashNewParam w = FNV1a_32 w hashEnd (FNV1a_32 w) = FNV1Hash32 (Prelude.fromIntegral w) hashMix8 = fnv1a_32_Mix8 hashMixBytes = fnv1a_32_mixBa instance Hasher FNV1_64 where type HashResult FNV1_64 = FNV1Hash64 + type HashInitParam FNV1_64 = Word64 hashNew = FNV1_64 0xcbf29ce484222325 + hashNewParam w = FNV1_64 w hashEnd (FNV1_64 w) = FNV1Hash64 (Prelude.fromIntegral w) hashMix8 = fnv1_64_Mix8 hashMixBytes = fnv1_64_mixBa instance Hasher FNV1a_64 where type HashResult FNV1a_64 = FNV1Hash64 + type HashInitParam FNV1a_64 = Word64 hashNew = FNV1a_64 0xcbf29ce484222325 + hashNewParam w = FNV1a_64 w hashEnd (FNV1a_64 w) = FNV1Hash64 (Prelude.fromIntegral w) hashMix8 = fnv1a_64_Mix8 hashMixBytes = fnv1a_64_mixBa diff --git a/Foundation/Hashing/Hasher.hs b/Foundation/Hashing/Hasher.hs --- a/Foundation/Hashing/Hasher.hs +++ b/Foundation/Hashing/Hasher.hs @@ -17,13 +17,19 @@ -- The class allow to define faster mixing function that works on -- bigger Word size and any unboxed array of any PrimType elements class Hasher st where - {-# MINIMAL hashNew, hashMix8, hashEnd #-} + {-# MINIMAL hashNew, hashNewParam, hashMix8, hashEnd #-} -- | Associate type when finalizing the state with 'hashEnd' type HashResult st + -- | Associate type when initializing the state (e.g. a Key or seed) + type HashInitParam st + -- | Create a new Hashing context hashNew :: st + + -- | Create a new Hashing context + hashNewParam :: HashInitParam st -> st -- | Finalize the state and returns the hash result hashEnd :: st -> HashResult st diff --git a/Foundation/Hashing/SipHash.hs b/Foundation/Hashing/SipHash.hs --- a/Foundation/Hashing/SipHash.hs +++ b/Foundation/Hashing/SipHash.hs @@ -13,6 +13,7 @@ {-# LANGUAGE UnboxedTuples #-} module Foundation.Hashing.SipHash ( SipKey(..) + , SipHash(..) , Sip1_3 , Sip2_4 ) where @@ -46,7 +47,9 @@ instance Hasher Sip2_4 where type HashResult Sip2_4 = SipHash + type HashInitParam Sip2_4 = SipKey hashNew = Sip2_4 $ newSipState (SipKey 0 0) + hashNewParam key = Sip2_4 $ newSipState key hashEnd (Sip2_4 st) = finish 2 4 st hashMix8 w (Sip2_4 st) = Sip2_4 $ mix8 2 w st hashMix32 w (Sip2_4 st) = Sip2_4 $ mix32 2 w st @@ -55,7 +58,9 @@ instance Hasher Sip1_3 where type HashResult Sip1_3 = SipHash + type HashInitParam Sip1_3 = SipKey hashNew = Sip1_3 $ newSipState (SipKey 0 0) + hashNewParam key = Sip1_3 $ newSipState key hashEnd (Sip1_3 st) = finish 1 3 st hashMix8 w (Sip1_3 st) = Sip1_3 $ mix8 1 w st hashMix32 w (Sip1_3 st) = Sip1_3 $ mix32 1 w st diff --git a/Foundation/Internal/Base.hs b/Foundation/Internal/Base.hs --- a/Foundation/Internal/Base.hs +++ b/Foundation/Internal/Base.hs @@ -82,6 +82,7 @@ import qualified GHC.Exts import qualified GHC.Generics import qualified GHC.Ptr +import GHC.Exts (fromString) -- | Only to use internally for internal error cases internalError :: [Prelude.Char] -> a diff --git a/Foundation/List/SList.hs b/Foundation/List/SList.hs new file mode 100644 --- /dev/null +++ b/Foundation/List/SList.hs @@ -0,0 +1,187 @@ +-- | +-- Module : Foundation.List.SList +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A Nat-sized list abstraction +-- +-- Using this module is limited to GHC 7.10 and above. +-- +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Foundation.List.SList + ( SList + , toSList + , unSList + , length + , create + , createFrom + , empty + , singleton + , uncons + , cons + , map + , elem + , foldl + , append + , minimum + , maximum + , head + , tail + , take + , drop + , zip, zip3, zip4, zip5 + , zipWith, zipWith3, zipWith4, zipWith5 + , replicateM + ) where + +import Data.Proxy +import Foundation.Internal.Base +import Foundation.Primitive.Nat +import Foundation.Numerical +import qualified Prelude +import qualified Control.Monad as M (replicateM) + +impossible :: a +impossible = error "SList: internal error: the impossible happened" + +newtype SList (n :: Nat) a = SList { unSList :: [a] } + +toSList :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (SList n a) +toSList l + | expected == Prelude.fromIntegral (Prelude.length l) = Just (SList l) + | otherwise = Nothing + where + expected = natValInt (Proxy :: Proxy n) + +replicateM :: forall (n :: Nat) m a . (n <= 0x100000, Monad m, KnownNat n) => m a -> m (SList n a) +replicateM action = SList <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action + +uncons :: CmpNat n 0 ~ 'GT => SList n a -> (a, SList (n-1) a) +uncons (SList (x:xs)) = (x, SList xs) +uncons _ = impossible + +cons :: a -> SList n a -> SList (n+1) a +cons a (SList l) = SList (a : l) + +empty :: SList 0 a +empty = SList [] + +length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => SList n a -> Int +length _ = natValInt (Proxy :: Proxy n) + +create :: forall a (n :: Nat) . KnownNat n => (Integer -> a) -> SList n a +create f = SList $ Prelude.map f [0..(len-1)] + where + len = natVal (Proxy :: Proxy n) + +createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start) + => Proxy start -> (Integer -> a) -> SList n a +createFrom p f = SList $ Prelude.map f [idx..(idx+len)] + where + len = natVal (Proxy :: Proxy n) + idx = natVal p + +singleton :: a -> SList 1 a +singleton a = SList [a] + +elem :: Eq a => a -> SList n a -> Bool +elem a (SList l) = Prelude.elem a l + +append :: SList n a -> SList m a -> SList (n+m) a +append (SList l1) (SList l2) = SList (l1 <> l2) + +maximum :: (Ord a, CmpNat n 0 ~ 'GT) => SList n a -> a +maximum (SList l) = Prelude.maximum l + +minimum :: (Ord a, CmpNat n 0 ~ 'GT) => SList n a -> a +minimum (SList l) = Prelude.minimum l + +head :: CmpNat n 0 ~ 'GT => SList n a -> a +head (SList (x:_)) = x +head _ = impossible + +tail :: CmpNat n 0 ~ 'GT => SList n a -> SList (n-1) a +tail (SList (_:xs)) = SList xs +tail _ = impossible + +take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => SList n a -> SList m a +take (SList l) = SList (Prelude.take n l) + where n = natValInt (Proxy :: Proxy m) + +drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => SList n a -> SList m a +drop (SList l) = SList (Prelude.drop n l) + where n = natValInt (Proxy :: Proxy d) + +map :: (a -> b) -> SList n a -> SList n b +map f (SList l) = SList (Prelude.map f l) + +foldl :: (b -> a -> b) -> b -> SList n a -> b +foldl f acc (SList l) = Prelude.foldl f acc l + +zip :: SList n a -> SList n b -> SList n (a,b) +zip (SList l1) (SList l2) = SList (Prelude.zip l1 l2) + +zip3 :: SList n a -> SList n b -> SList n c -> SList n (a,b,c) +zip3 (SList x1) (SList x2) (SList x3) = SList (loop x1 x2 x3) + where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s + loop [] _ _ = [] + loop _ _ _ = impossible + +zip4 :: SList n a -> SList n b -> SList n c -> SList n d -> SList n (a,b,c,d) +zip4 (SList x1) (SList x2) (SList x3) (SList x4) = SList (loop x1 x2 x3 x4) + where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s + loop [] _ _ _ = [] + loop _ _ _ _ = impossible + +zip5 :: SList n a -> SList n b -> SList n c -> SList n d -> SList n e -> SList n (a,b,c,d,e) +zip5 (SList x1) (SList x2) (SList x3) (SList x4) (SList x5) = SList (loop x1 x2 x3 x4 x5) + where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s + loop [] _ _ _ _ = [] + loop _ _ _ _ _ = impossible + +zipWith :: (a -> b -> x) -> SList n a -> SList n b -> SList n x +zipWith f (SList (v1:vs)) (SList (w1:ws)) = SList (f v1 w1 : unSList (zipWith f (SList vs) (SList ws))) +zipWith _ (SList []) _ = SList [] +zipWith _ _ _ = impossible + +zipWith3 :: (a -> b -> c -> x) + -> SList n a + -> SList n b + -> SList n c + -> SList n x +zipWith3 f (SList (v1:vs)) (SList (w1:ws)) (SList (x1:xs)) = + SList (f v1 w1 x1 : unSList (zipWith3 f (SList vs) (SList ws) (SList xs))) +zipWith3 _ (SList []) _ _ = SList [] +zipWith3 _ _ _ _ = impossible + +zipWith4 :: (a -> b -> c -> d -> x) + -> SList n a + -> SList n b + -> SList n c + -> SList n d + -> SList n x +zipWith4 f (SList (v1:vs)) (SList (w1:ws)) (SList (x1:xs)) (SList (y1:ys)) = + SList (f v1 w1 x1 y1 : unSList (zipWith4 f (SList vs) (SList ws) (SList xs) (SList ys))) +zipWith4 _ (SList []) _ _ _ = SList [] +zipWith4 _ _ _ _ _ = impossible + +zipWith5 :: (a -> b -> c -> d -> e -> x) + -> SList n a + -> SList n b + -> SList n c + -> SList n d + -> SList n e + -> SList n x +zipWith5 f (SList (v1:vs)) (SList (w1:ws)) (SList (x1:xs)) (SList (y1:ys)) (SList (z1:zs)) = + SList (f v1 w1 x1 y1 z1 : unSList (zipWith5 f (SList vs) (SList ws) (SList xs) (SList ys) (SList zs))) +zipWith5 _ (SList []) _ _ _ _ = SList [] +zipWith5 _ _ _ _ _ _ = impossible diff --git a/Foundation/Monad.hs b/Foundation/Monad.hs --- a/Foundation/Monad.hs +++ b/Foundation/Monad.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} module Foundation.Monad ( MonadIO(..) , MonadFailure(..) @@ -23,13 +24,20 @@ import Control.Monad.Fix import Control.Monad.Zip import Foundation.Internal.Base + +#if MIN_VERSION_base(4,6,0) import GHC.Generics (Generic1) +#endif -- | Identity functor and monad. (a non-strict monad) -- -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a } - deriving (Eq, Ord, Data, Generic, Generic1, Typeable) + deriving (Eq, Ord, Data, Generic, Typeable) + +#if MIN_VERSION_base(4,6,0) +deriving instance Generic1 Identity +#endif instance Functor Identity where fmap f (Identity x) = Identity (f x) diff --git a/Foundation/Network/HostName.hsc b/Foundation/Network/HostName.hsc new file mode 100644 --- /dev/null +++ b/Foundation/Network/HostName.hsc @@ -0,0 +1,169 @@ +-- | +-- Module : Foundation.Network.HostName +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : experimental +-- Portability : portable +-- +-- HostName and HostName info +-- +-- > getHostNameInfo "github.com" :: IO (HostNameInfo IPv4) +-- +-- > getHostNameInfo "google.com" :: IO (HostNameInfo IPv6) +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Foundation.Network.HostName + ( HostName(..) + , HostNameInfo(..) + , getHostNameInfo + , getHostNameInfo_ + ) where + +import Foundation.Class.Storable +import Foundation.Internal.Base +import Foundation.Internal.Proxy +import Foundation.Hashing (Hashable) +import Foundation.String +import Foundation.Array +import Foundation.Collection.Mappable +import Foundation.Network.IPv4 (IPv4) +import Foundation.Network.IPv6 (IPv6) + +import Foundation.System.Bindings.Network + +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr (nullPtr) +import Control.Concurrent.MVar +import System.IO.Unsafe (unsafePerformIO) + +import Control.Monad ((=<<)) + +#ifdef mingw32_HOST_OS +# include +#else +# include +# include +# include +#endif + +-- | HostName +-- +newtype HostName = HostName { toString :: String } + deriving (Eq, Ord, Typeable, Hashable) +instance Show HostName where + show = show . toString +instance IsString HostName where + fromString = HostName . fromString + +-- | HostName Info +data HostNameInfo address_type = HostNameInfo + { officialName :: !HostName + -- ^ official names + , aliases :: !(Array HostName) + -- ^ known aliases + , addresses :: !(Array address_type) + -- ^ known addresses + } deriving (Show, Eq, Ord, Typeable) + +-- | HostName errors +data HostNameError + = HostNotFound !HostName + -- ^ the given HostMame was not found + | NoAssociatedData !HostName + -- ^ there is not associated info/data to the given HostName + -- + -- i.e. : no IPv4 info? This might mean you should try IPv6 ? + | FatalError + -- ^ getHostNameInfo uses *C* a binding to get the `HostNameInfo` + -- + -- a fatal error is linked to the underlying *C* function and is not + -- recoverable. + | UnknownError !CInt + -- ^ Unknown Error, `CInt` is the associated error code. + -- + -- see man gethostbyname for more information + deriving (Show,Eq,Typeable) + +instance Exception HostNameError + +-- TODO: move this when we have socket family and domain name... +class SocketFamily a where + familyCode :: proxy a -> CInt +instance SocketFamily IPv4 where + familyCode _ = (#const AF_INET) +instance SocketFamily IPv6 where + familyCode _ = (#const AF_INET6) + +-- | get `HostName` info: +-- +-- retrieve the official name, the aliases and the addresses associated to this +-- hostname. +-- +-- For cross-platform compatibility purpose, this function is using a *C* non +-- re-entrant function `gethostbyname2`. This function is using a `MVar ()` to +-- avoid a race condition and should be safe to use. +-- +getHostNameInfo :: (Eq address_type, Storable address_type, SocketFamily address_type) + => HostName + -> IO (HostNameInfo address_type) +getHostNameInfo = getHostNameInfo_ Proxy + +globalMutex :: MVar () +globalMutex = unsafePerformIO (newMVar ()) +{-# NOINLINE globalMutex #-} + +-- | like `getHostNameInfo` but takes a `Proxy` to help with the type checker. +getHostNameInfo_ :: (SocketFamily address_type, Eq address_type, Storable address_type) + => Proxy address_type + -> HostName + -> IO (HostNameInfo address_type) +getHostNameInfo_ p h@(HostName hn) = + withMVar globalMutex $ \_ -> + withCString (toList hn) $ \cname -> do + ptr <- loop $ c_gethostbyname2 cname (familyCode p) + + on <- peekHostName . castPtr =<< peek (castPtr $ offname_ptr ptr) + + as <- getAliases . castPtr =<< peek (castPtr $ aliases_ptr ptr) + + addrs <- getAddresses p . castPtr =<< peek (castPtr $ addr_list ptr) + return $ HostNameInfo on as addrs + where + loop f = do + ptr <- f + if ptr /= nullPtr + then return ptr + else do + err <- getHErrno + case err of + _ | err == herr_NoData -> throwIO $ NoAssociatedData h + | err == herr_HostNotFound -> throwIO $ HostNotFound h + | err == herr_TryAgain -> loop f + | err == herr_NoRecovery -> throwIO FatalError + | otherwise -> throwIO $ UnknownError err + offname_ptr = (#ptr struct hostent, h_name) + aliases_ptr = (#ptr struct hostent, h_aliases) + addr_list = (#ptr struct hostent, h_addr_list) + +peekHostName :: Ptr Word8 -> IO HostName +peekHostName ptr = HostName . fst . fromBytesLenient <$> peekArrayEndedBy 0x00 ptr + +getAliases :: Ptr (Ptr Word8) -> IO (Array HostName) +getAliases ptr = do + arr <- peekArrayEndedBy nullPtr ptr + forM arr peekHostName + +getAddresses :: Storable address_type + => Proxy address_type + -> Ptr (Ptr address_type) + -> IO (Array address_type) +getAddresses _ ptr = do + arr <- peekArrayEndedBy nullPtr ptr + forM arr peek + +foreign import ccall safe "gethostbyname2" + c_gethostbyname2 :: CString -> CInt -> IO (Ptr Word8) diff --git a/Foundation/Network/IPv4.hs b/Foundation/Network/IPv4.hs --- a/Foundation/Network/IPv4.hs +++ b/Foundation/Network/IPv4.hs @@ -1,8 +1,18 @@ +-- | +-- Module : Foundation.Network.IPv4 +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : experimental +-- Portability : portable +-- +-- IPv4 data type +-- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Network.IPv4 ( IPv4 + , any, loopback , fromString, toString , fromTuple, toTuple , ipv4Parser @@ -18,7 +28,7 @@ import Foundation.Primitive import Foundation.Bits import Foundation.Parser -import Foundation.Collection +import Foundation.Collection (Sequential, Element, elem) -- | IPv4 data type newtype IPv4 = IPv4 Word32 @@ -33,6 +43,14 @@ instance StorableFixed IPv4 where size _ = size (Proxy :: Proxy Word32) alignment _ = alignment (Proxy :: Proxy Word32) + +-- | "0.0.0.0" +any :: IPv4 +any = fromTuple (0,0,0,0) + +-- | "127.0.0.1" +loopback :: IPv4 +loopback = fromTuple (127,0,0,1) toString :: IPv4 -> String toString = fromList . toLString diff --git a/Foundation/Network/IPv6.hs b/Foundation/Network/IPv6.hs --- a/Foundation/Network/IPv6.hs +++ b/Foundation/Network/IPv6.hs @@ -13,6 +13,7 @@ module Foundation.Network.IPv6 ( IPv6 + , any, loopback , fromString, toString , fromTuple, toTuple -- * parsers @@ -35,7 +36,7 @@ import Foundation.Internal.Proxy import Foundation.Primitive import Foundation.Numerical -import Foundation.Collection +import Foundation.Collection (Sequential, Element, length, intercalate, null) import Foundation.Parser import Foundation.String (String) import Foundation.Bits @@ -80,6 +81,14 @@ instance StorableFixed IPv6 where size _ = (size (Proxy :: Proxy Word64)) `scale` 2 alignment _ = alignment (Proxy :: Proxy Word64) + +-- | equivalent to `::` +any :: IPv6 +any = fromTuple (0,0,0,0,0,0,0,0) + +-- | equivalent to `::1` +loopback :: IPv6 +loopback = fromTuple (0,0,0,0,0,0,0,1) -- | serialise to human readable IPv6 -- diff --git a/Foundation/Primitive.hs b/Foundation/Primitive.hs --- a/Foundation/Primitive.hs +++ b/Foundation/Primitive.hs @@ -18,8 +18,14 @@ , ByteSwap , LE(..), toLE, fromLE , BE(..), toBE, fromBE + + -- * Integral convertion + , IntegralUpsize(..) + , IntegralDownsize(..) + , IntegralCast(..) ) where import Foundation.Primitive.Types import Foundation.Primitive.Monad import Foundation.Primitive.Endianness +import Foundation.Primitive.IntegralConv diff --git a/Foundation/Primitive/Base16.hs b/Foundation/Primitive/Base16.hs --- a/Foundation/Primitive/Base16.hs +++ b/Foundation/Primitive/Base16.hs @@ -2,26 +2,53 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE BangPatterns #-} module Foundation.Primitive.Base16 - ( convertByte + ( unsafeConvertByte + , hexWord16 + , hexWord32 ) where import GHC.Prim +import GHC.Types +import GHC.Word -- | Convert a byte value in Word# to two Word#s containing -- the hexadecimal representation of the Word# -- +-- The output words# are guaranteed to be included in the 0 to 2^7-1 range +-- -- Note that calling convertByte with a value greater than 256 -- will cause segfault or other horrible effect. -convertByte :: Word# -> (# Word#, Word# #) -convertByte b = (# r tableHi b, r tableLo b #) +unsafeConvertByte :: Word# -> (# Word#, Word# #) +unsafeConvertByte b = (# r tableHi b, r tableLo b #) where - r :: Table -> Word# -> Word# - r (Table !table) index = indexWord8OffAddr# table (word2Int# index) -{-# INLINE convertByte #-} + r :: Table -> Word# -> Word# + r (Table !table) index = indexWord8OffAddr# table (word2Int# index) +{-# INLINE unsafeConvertByte #-} +-- | hex word16 +hexWord16 :: Word16 -> (Char, Char, Char, Char) +hexWord16 (W16# w) = (toChar w1,toChar w2,toChar w3,toChar w4) + where + toChar :: Word# -> Char + toChar c = C# (chr# (word2Int# c)) + (# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 8#) + (# w3, w4 #) = unsafeConvertByte (and# w 0xff##) + +-- | hex word32 +hexWord32 :: Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char) +hexWord32 (W32# w) = (toChar w1,toChar w2,toChar w3,toChar w4 + ,toChar w5,toChar w6,toChar w7,toChar w8) + where + toChar :: Word# -> Char + toChar c = C# (chr# (word2Int# c)) + (# w1, w2 #) = unsafeConvertByte (uncheckedShiftRL# w 24#) + (# w3, w4 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 16#) 0xff##) + (# w5, w6 #) = unsafeConvertByte (and# (uncheckedShiftRL# w 8#) 0xff##) + (# w7, w8 #) = unsafeConvertByte (and# w 0xff##) + data Table = Table Addr# -tableLo :: Table +tableLo:: Table tableLo = Table "0123456789abcdef0123456789abcdef\ \0123456789abcdef0123456789abcdef\ diff --git a/Foundation/Primitive/Endianness.hs b/Foundation/Primitive/Endianness.hs --- a/Foundation/Primitive/Endianness.hs +++ b/Foundation/Primitive/Endianness.hs @@ -18,15 +18,32 @@ , BE(..), toBE, fromBE -- * Little Endian , LE(..), toLE, fromLE + -- * System Endianness + , Endianness(..) + , endianness ) where import Foundation.Internal.Base import Foundation.Internal.ByteSwap -#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) -import Foundation.System.Info (endianness, Endianness(..)) +#ifdef ARCH_IS_UNKNOWN_ENDIAN +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (castPtr) +import Foreign.Storable (poke, peek) +import Data.Word (Word8, Word32) +import System.IO.Unsafe (unsafePerformIO) #endif + +-- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) +-- import Foundation.System.Info (endianness, Endianness(..)) +-- #endif + +data Endianness = + LittleEndian + | BigEndian + deriving (Eq, Show) + -- | Little Endian value newtype LE a = LE { unLE :: a } deriving (Show, Eq, Typeable) @@ -82,3 +99,27 @@ fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a #endif {-# INLINE fromLE #-} + +-- | endianness of the current architecture +endianness :: Endianness +#ifdef ARCH_IS_LITTLE_ENDIAN +endianness = LittleEndian +#elif ARCH_IS_BIG_ENDIAN +endianness = BigEndian +#else +-- ! ARCH_IS_UNKNOWN_ENDIAN +endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input + where + input :: Word32 + input = 0x01020304 +{-# NOINLINE endianness #-} + +word32ToByte :: Word32 -> IO Word8 +word32ToByte word = alloca $ \wordPtr -> do + poke wordPtr word + peek (castPtr wordPtr) + +bytesToEndianness :: Word8 -> Endianness +bytesToEndianness 1 = BigEndian +bytesToEndianness _ = LittleEndian +#endif diff --git a/Foundation/Primitive/IntegralConv.hs b/Foundation/Primitive/IntegralConv.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/IntegralConv.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +module Foundation.Primitive.IntegralConv + ( IntegralDownsize(..) + , IntegralUpsize(..) + , IntegralCast(..) + , intToInt64 + , wordToWord64 + , word64ToWord32s + , word64ToWord + ) where + +#include "MachDeps.h" + +import GHC.Types +import GHC.Prim +import GHC.Int +import GHC.Word +import Prelude (Integer, fromIntegral) +import Foundation.Internal.Base +import Foundation.Internal.Natural + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +-- | Downsize an integral value +class IntegralDownsize a b where + integralDownsize :: a -> b + default integralDownsize :: a ~ b => a -> b + integralDownsize = id + + integralDownsizeCheck :: a -> Maybe b + +-- | Upsize an integral value +-- +-- The destination type 'b' size need to be greater or equal +-- than the size type of 'a' +class IntegralUpsize a b where + integralUpsize :: a -> b + +-- | Cast an integral value to another value +-- that have the same representional size +class IntegralCast a b where + integralCast :: a -> b + default integralCast :: a ~ b => a -> b + integralCast = id + +integralDownsizeBounded :: forall a b . (Ord a, Bounded b, IntegralDownsize a b, IntegralUpsize b a) + => (a -> b) + -> a + -> Maybe b +integralDownsizeBounded aToB x + | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing + | otherwise = Just (aToB x) + +instance IntegralUpsize Int8 Int16 where + integralUpsize (I8# i) = I16# i +instance IntegralUpsize Int8 Int32 where + integralUpsize (I8# i) = I32# i +instance IntegralUpsize Int8 Int64 where + integralUpsize (I8# i) = intToInt64 (I# i) +instance IntegralUpsize Int8 Int where + integralUpsize (I8# i) = I# i +instance IntegralUpsize Int8 Integer where + integralUpsize = fromIntegral + +instance IntegralUpsize Int16 Int32 where + integralUpsize (I16# i) = I32# i +instance IntegralUpsize Int16 Int64 where + integralUpsize (I16# i) = intToInt64 (I# i) +instance IntegralUpsize Int16 Int where + integralUpsize (I16# i) = I# i +instance IntegralUpsize Int16 Integer where + integralUpsize = fromIntegral + +instance IntegralUpsize Int32 Int64 where + integralUpsize (I32# i) = intToInt64 (I# i) +instance IntegralUpsize Int32 Int where + integralUpsize (I32# i) = I# i +instance IntegralUpsize Int32 Integer where + integralUpsize = fromIntegral + +instance IntegralUpsize Int64 Integer where + integralUpsize = fromIntegral + +instance IntegralUpsize Word8 Word16 where + integralUpsize (W8# i) = W16# i +instance IntegralUpsize Word8 Word32 where + integralUpsize (W8# i) = W32# i +instance IntegralUpsize Word8 Word64 where + integralUpsize (W8# i) = wordToWord64 (W# i) +instance IntegralUpsize Word8 Word where + integralUpsize (W8# i) = W# i +instance IntegralUpsize Word8 Integer where + integralUpsize = fromIntegral +instance IntegralUpsize Word8 Natural where + integralUpsize = fromIntegral + +instance IntegralUpsize Word16 Word32 where + integralUpsize (W16# i) = W32# i +instance IntegralUpsize Word16 Word64 where + integralUpsize (W16# i) = wordToWord64 (W# i) +instance IntegralUpsize Word16 Word where + integralUpsize (W16# i) = W# i +instance IntegralUpsize Word16 Integer where + integralUpsize = fromIntegral +instance IntegralUpsize Word16 Natural where + integralUpsize = fromIntegral + +instance IntegralUpsize Word32 Word64 where + integralUpsize (W32# i) = wordToWord64 (W# i) +instance IntegralUpsize Word32 Word where + integralUpsize (W32# i) = W# i +instance IntegralUpsize Word32 Integer where + integralUpsize = fromIntegral +instance IntegralUpsize Word32 Natural where + integralUpsize = fromIntegral + +instance IntegralUpsize Word64 Integer where + integralUpsize = fromIntegral +instance IntegralUpsize Word64 Natural where + integralUpsize = fromIntegral + +instance IntegralDownsize Int Int8 where + integralDownsize (I# i) = I8# (narrow8Int# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int Int16 where + integralDownsize (I# i) = I16# (narrow16Int# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Int Int32 where + integralDownsize (I# i) = I32# (narrow32Int# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word64 Word8 where + integralDownsize (W64# i) = W8# (narrow8Word# (word64ToWord# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word64 Word16 where + integralDownsize (W64# i) = W16# (narrow16Word# (word64ToWord# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word64 Word32 where + integralDownsize (W64# i) = W32# (narrow32Word# (word64ToWord# i)) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word32 Word8 where + integralDownsize (W32# i) = W8# (narrow8Word# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Word32 Word16 where + integralDownsize (W32# i) = W16# (narrow16Word# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Word16 Word8 where + integralDownsize (W16# i) = W8# (narrow8Word# i) + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Integer Int8 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Int16 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Int32 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Int64 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralDownsize Integer Word8 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Word16 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Word32 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Word64 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Integer Natural where + integralDownsize i + | i >= 0 = fromIntegral i + | otherwise = 0 + integralDownsizeCheck i + | i >= 0 = Just (fromIntegral i) + | otherwise = Nothing + +instance IntegralDownsize Natural Word8 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Natural Word16 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Natural Word32 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize +instance IntegralDownsize Natural Word64 where + integralDownsize = fromIntegral + integralDownsizeCheck = integralDownsizeBounded integralDownsize + +instance IntegralCast Word Int where + integralCast (W# w) = I# (word2Int# w) +instance IntegralCast Int Word where + integralCast (I# i) = W# (int2Word# i) +instance IntegralCast Word64 Int64 where +#if WORD_SIZE_IN_BITS == 64 + integralCast (W64# i) = I64# (word2Int# i) +#else + integralCast (W64# i) = I64# (word64ToInt64# i) +#endif +instance IntegralCast Int64 Word64 where +#if WORD_SIZE_IN_BITS == 64 + integralCast (I64# i) = W64# (int2Word# i) +#else + integralCast (I64# i) = W64# (int64ToWord64# i) +#endif + +-- missing word8, word16, word32, word64 +-- instance IntegralCast Word8 Int8 where +-- instance IntegralCast Int8 Word8 where + +intToInt64 :: Int -> Int64 +#if WORD_SIZE_IN_BITS == 64 +intToInt64 (I# i) = I64# i +#else +intToInt64 (I# i) = I64# (intToInt64# i) +#endif + +wordToWord64 :: Word -> Word64 +#if WORD_SIZE_IN_BITS == 64 +wordToWord64 (W# i) = W64# i +#else +wordToWord64 (W# i) = W64# (wordToWord64# i) +#endif + +word64ToWord :: Word64 -> Word +#if WORD_SIZE_IN_BITS == 64 +word64ToWord (W64# i) = W# i +#else +word64ToWord (W64# i) = W# (word64ToWord# i) +#endif + +#if WORD_SIZE_IN_BITS == 64 +word64ToWord# :: Word# -> Word# +word64ToWord# i = i +{-# INLINE word64ToWord# #-} +#endif + +#if WORD_SIZE_IN_BITS == 64 +word64ToWord32s :: Word64 -> (# Word32, Word32 #) +word64ToWord32s (W64# w) = (# W32# (uncheckedShiftRL# w 32#), W32# (narrow32Word# w) #) +#else +word64ToWord32s :: Word64 -> (# Word32, Word32 #) +word64ToWord32s (W64# w) = (# W32# (word64ToWord# (uncheckedShiftRL64# w 32#)), W32# (word64ToWord# w) #) +#endif diff --git a/Foundation/Primitive/Nat.hs b/Foundation/Primitive/Nat.hs new file mode 100644 --- /dev/null +++ b/Foundation/Primitive/Nat.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ < 710 +# error "IMPORT ERROR: cannot include this file with GHC version below 7.10 +#else +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE ConstraintKinds #-} +#endif +module Foundation.Primitive.Nat + ( Nat + , KnownNat + , natVal + , type (<=), type (<=?), type (+), type (*), type (^), type (-) + , CmpNat + -- * Nat convertion + , natValInt + , natValInt8 + , natValInt16 + , natValInt32 + , natValInt64 + , natValWord + , natValWord8 + , natValWord16 + , natValWord32 + , natValWord64 + -- * Maximum bounds + , NatNumMaxBound + -- * Constraint + , NatInBoundOf + , NatWithinBound + ) where + +#include "MachDeps.h" + +import GHC.TypeLits +import Foundation.Internal.Base +import Foundation.Internal.Natural +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import qualified Prelude (fromIntegral) + +#if __GLASGOW_HASKELL__ >= 800 +import Data.Type.Bool +#endif + +natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int +natValInt n = Prelude.fromIntegral (natVal n) + +natValInt64 :: forall n proxy . (KnownNat n, NatWithinBound Int64 n) => proxy n -> Int64 +natValInt64 n = Prelude.fromIntegral (natVal n) + +natValInt32 :: forall n proxy . (KnownNat n, NatWithinBound Int32 n) => proxy n -> Int32 +natValInt32 n = Prelude.fromIntegral (natVal n) + +natValInt16 :: forall n proxy . (KnownNat n, NatWithinBound Int16 n) => proxy n -> Int16 +natValInt16 n = Prelude.fromIntegral (natVal n) + +natValInt8 :: forall n proxy . (KnownNat n, NatWithinBound Int8 n) => proxy n -> Int8 +natValInt8 n = Prelude.fromIntegral (natVal n) + +natValWord :: forall n proxy . (KnownNat n, NatWithinBound Word n) => proxy n -> Word +natValWord n = Prelude.fromIntegral (natVal n) + +natValWord64 :: forall n proxy . (KnownNat n, NatWithinBound Word64 n) => proxy n -> Word64 +natValWord64 n = Prelude.fromIntegral (natVal n) + +natValWord32 :: forall n proxy . (KnownNat n, NatWithinBound Word32 n) => proxy n -> Word32 +natValWord32 n = Prelude.fromIntegral (natVal n) + +natValWord16 :: forall n proxy . (KnownNat n, NatWithinBound Word16 n) => proxy n -> Word16 +natValWord16 n = Prelude.fromIntegral (natVal n) + +natValWord8 :: forall n proxy . (KnownNat n, NatWithinBound Word8 n) => proxy n -> Word8 +natValWord8 n = Prelude.fromIntegral (natVal n) + +-- | Get Maximum bounds of different Integral / Natural types related to Nat +type family NatNumMaxBound ty where + NatNumMaxBound Int64 = 0x7fffffffffffffff + NatNumMaxBound Int32 = 0x7fffffff + NatNumMaxBound Int16 = 0x7fff + NatNumMaxBound Int8 = 0x7f + NatNumMaxBound Word64 = 0xffffffffffffffff + NatNumMaxBound Word32 = 0xffffffff + NatNumMaxBound Word16 = 0xffff + NatNumMaxBound Word8 = 0xff +#if WORD_SIZE_IN_BITS == 64 + NatNumMaxBound Int = NatNumMaxBound Int64 + NatNumMaxBound Word = NatNumMaxBound Word64 +#else + NatNumMaxBound Int = NatNumMaxBound Int32 + NatNumMaxBound Word = NatNumMaxBound Word32 +#endif + +-- | Check if a Nat is in bounds of another integral / natural types +type family NatInBoundOf ty n where + NatInBoundOf Integer n = 'True + NatInBoundOf Natural n = 'True + NatInBoundOf ty n = n <=? NatNumMaxBound ty + +-- | Constraint to check if a natural is within a specific bounds of a type. +-- +-- i.e. given a Nat `n`, is it possible to convert it to `ty` without losing information +#if __GLASGOW_HASKELL__ >= 800 +type family NatWithinBound ty (n :: Nat) where + NatWithinBound ty n = If (NatInBoundOf ty n) + (() ~ ()) + (TypeError ('Text "Natural " ':<>: 'ShowType n ':<>: 'Text " is out of bounds for " ':<>: 'ShowType ty)) +#else +type NatWithinBound ty n = NatInBoundOf ty n ~ 'True +#endif + +#endif diff --git a/Foundation/Primitive/Types.hs b/Foundation/Primitive/Types.hs --- a/Foundation/Primitive/Types.hs +++ b/Foundation/Primitive/Types.hs @@ -1,4 +1,3 @@ --- | -- Module : Foundation.Primitive.Types -- License : BSD-style -- Maintainer : Vincent Hanquez @@ -23,8 +22,13 @@ , sizeRecast , offsetAsSize , sizeAsOffset + , primWordGetByteAndShift + , primWord64GetByteAndShift + , primWord64GetHiLo ) where +#include "MachDeps.h" + import GHC.Prim import GHC.Int import GHC.Types @@ -37,6 +41,10 @@ import Foundation.Primitive.Monad import qualified Prelude (quot) +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + #ifdef FOUNDATION_BOUNDS_CHECK divBytes :: PrimType ty => Offset ty -> (Int -> Int) @@ -189,8 +197,49 @@ -> ty -> prim () +sizeInt, sizeWord :: Size Word8 +#if WORD_SIZE_IN_BITS == 64 +sizeInt = Size 8 +sizeWord = Size 8 +#else +sizeInt = Size 4 +sizeWord = Size 4 +#endif + {-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-} +instance PrimType Int where + primSizeInBytes _ = sizeInt + {-# INLINE primSizeInBytes #-} + primBaUIndex ba (Offset (I# n)) = I# (indexIntArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readIntArray# mba n s1 in (# s2, I# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = I# (indexIntOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readIntOffAddr# addr n s1 in (# s2, I# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (I# w) = primitive $ \s1 -> (# writeIntOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + +instance PrimType Word where + primSizeInBytes _ = sizeWord + {-# INLINE primSizeInBytes #-} + primBaUIndex ba (Offset (I# n)) = W# (indexWordArray# ba n) + {-# INLINE primBaUIndex #-} + primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWordArray# mba n s1 in (# s2, W# r #) + {-# INLINE primMbaURead #-} + primMbaUWrite mba (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordArray# mba n w s1, () #) + {-# INLINE primMbaUWrite #-} + primAddrIndex addr (Offset (I# n)) = W# (indexWordOffAddr# addr n) + {-# INLINE primAddrIndex #-} + primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWordOffAddr# addr n s1 in (# s2, W# r #) + {-# INLINE primAddrRead #-} + primAddrWrite addr (Offset (I# n)) (W# w) = primitive $ \s1 -> (# writeWordOffAddr# addr n w s1, () #) + {-# INLINE primAddrWrite #-} + instance PrimType Word8 where primSizeInBytes _ = Size 1 {-# INLINE primSizeInBytes #-} @@ -454,3 +503,22 @@ offsetAsSize :: Offset a -> Size a offsetAsSize (Offset a) = Size a {-# INLINE offsetAsSize #-} + +primWordGetByteAndShift :: Word# -> (# Word#, Word# #) +primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #) +{-# INLINE primWordGetByteAndShift #-} + +#if WORD_SIZE_IN_BITS == 64 +primWord64GetByteAndShift :: Word# -> (# Word#, Word# #) +primWord64GetByteAndShift = primWord64GetByteAndShift + +primWord64GetHiLo :: Word# -> (# Word#, Word# #) +primWord64GetHiLo w = (# uncheckedShiftRL# w 32# , and# w 0xffffffff## #) +#else +primWord64GetByteAndShift :: Word64# -> (# Word#, Word64# #) +primWord64GetByteAndShift w = (# and# (word64ToWord# w) 0xff##, uncheckedShiftRL64# w 8# #) + +primWord64GetHiLo :: Word64# -> (# Word#, Word# #) +primWord64GetHiLo w = (# word64ToWord# (uncheckedShiftRL64# w 32#), word64ToWord# w #) +#endif +{-# INLINE primWord64GetByteAndShift #-} diff --git a/Foundation/Random.hs b/Foundation/Random.hs --- a/Foundation/Random.hs +++ b/Foundation/Random.hs @@ -16,10 +16,12 @@ -- abstract a generator. -- {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} module Foundation.Random ( MonadRandom(..) , MonadRandomState(..) , RandomGen(..) + , getRandomPrimType , withRandomGenerator , RNG , RNGv1 @@ -27,6 +29,7 @@ import Foundation.Internal.Base import Foundation.Internal.Types +import Foundation.Internal.Proxy import Foundation.Primitive.Monad import Foundation.System.Entropy import Foundation.Array @@ -37,7 +40,7 @@ -- | A monad constraint that allows to generate random bytes class (Functor m, Applicative m, Monad m) => MonadRandom m where - getRandomBytes :: Int -> m (UArray Word8) + getRandomBytes :: Size Word8 -> m (UArray Word8) instance MonadRandom IO where getRandomBytes = getEntropy @@ -47,8 +50,14 @@ -- | Initialize a new random generator randomNew :: MonadRandom m => m gen + -- | Initialize a new random generator from a binary seed. + -- + -- If `Nothing` is returned, then the data is not acceptable + -- for creating a new random generator. + randomNewFrom :: UArray Word8 -> Maybe gen + -- | Generate N bytes of randomness from a DRG - randomGenerate :: Int -> gen -> (UArray Word8, gen) + randomGenerate :: Size Word8 -> gen -> (UArray Word8, gen) -- | A simple Monad class very similar to a State Monad -- with the state being a RandomGenerator. @@ -74,6 +83,10 @@ instance RandomGen gen => MonadRandom (MonadRandomState gen) where getRandomBytes n = MonadRandomState (randomGenerate n) +getRandomPrimType :: forall randomly ty . (PrimType ty, MonadRandom randomly) => randomly ty +getRandomPrimType = + flip A.index 0 . A.unsafeRecast <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy ty)) + -- | Run a pure computation with a Random Generator in the 'MonadRandomState' withRandomGenerator :: RandomGen gen => gen @@ -97,19 +110,22 @@ instance RandomGen RNGv1 where randomNew = RNGv1 <$> getRandomBytes 32 + randomNewFrom bs + | A.length bs == 32 = Just $ RNGv1 bs + | otherwise = Nothing randomGenerate = rngv1Generate -rngv1KeySize :: Int +rngv1KeySize :: Size Word8 rngv1KeySize = 32 -rngv1Generate :: Int -> RNGv1 -> (UArray Word8, RNGv1) -rngv1Generate n (RNGv1 key) = runST $ do - dst <- A.newPinned (Size n) - newKey <- A.newPinned (Size $ rngv1KeySize) +rngv1Generate :: Size Word8 -> RNGv1 -> (UArray Word8, RNGv1) +rngv1Generate n@(Size x) (RNGv1 key) = runST $ do + dst <- A.newPinned n + newKey <- A.newPinned rngv1KeySize A.withMutablePtr dst $ \dstP -> A.withMutablePtr newKey $ \newKeyP -> A.withPtr key $ \keyP -> do - _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP (Prelude.fromIntegral n) + _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP (Prelude.fromIntegral x) return () (,) <$> A.unsafeFreeze dst <*> (RNGv1 <$> A.unsafeFreeze newKey) diff --git a/Foundation/String/UTF8.hs b/Foundation/String/UTF8.hs --- a/Foundation/String/UTF8.hs +++ b/Foundation/String/UTF8.hs @@ -623,7 +623,7 @@ -- splitOn :: (Char -> Bool) -> String -> [String] splitOn predicate s - | sz == Size 0 = [] + | sz == Size 0 = [mempty] | otherwise = loop azero azero where !sz = size s @@ -955,11 +955,9 @@ unsnoc :: String -> Maybe (String, Char) unsnoc s | null s = Nothing - | otherwise = - let (s1,s2) = revSplitAt 1 s - in case toList s1 of -- TODO use index instead of toList - [c] -> Just (s2, c) - _ -> internalError "unsnoc" + | otherwise = case index s (length s - 1) of + Nothing -> Nothing + Just c -> Just (revDrop 1 s, c) -- | Extract the First character of a string, and the String stripped of the first character. -- @@ -967,11 +965,9 @@ uncons :: String -> Maybe (Char, String) uncons s | null s = Nothing - | otherwise = - let (s1,s2) = splitAt 1 s - in case toList s1 of -- TODO use index instead of ToList - [c] -> Just (c, s2) - _ -> internalError "uncons" + | otherwise = case index s 0 of + Nothing -> Nothing + Just c -> Just (c, drop 1 s) -- | Look for a predicate in the String and return the matched character, if any. find :: (Char -> Bool) -> String -> Maybe Char diff --git a/Foundation/System/Bindings/Network.hsc b/Foundation/System/Bindings/Network.hsc new file mode 100644 --- /dev/null +++ b/Foundation/System/Bindings/Network.hsc @@ -0,0 +1,45 @@ +-- | +-- Module : Foundation.System.Bindings.HostName +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : provisional +-- Portability : portable +-- +module Foundation.System.Bindings.Network + ( -- * error + getHErrno + , herr_HostNotFound + , herr_NoData + , herr_NoRecovery + , herr_TryAgain + ) where + +import Foundation.Internal.Base +import Foreign.C.Types + +#ifdef mingw32_HOST_OS +# include +#else +# include "netinet/in.h" +# include "netdb.h" +#endif + +herr_HostNotFound + , herr_NoData + , herr_NoRecovery + , herr_TryAgain + :: CInt +#ifdef mingw32_HOST_OS +herr_HostNotFound = (#const WSAHOST_NOT_FOUND) +herr_NoData = (#const WSANO_DATA) +herr_NoRecovery = (#const WSANO_RECOVERY) +herr_TryAgain = (#const WSATRY_AGAIN) +#else +herr_HostNotFound = (#const HOST_NOT_FOUND) +herr_NoData = (#const NO_DATA) +herr_NoRecovery = (#const NO_RECOVERY) +herr_TryAgain = (#const TRY_AGAIN) +#endif + +foreign import ccall unsafe "foundation_network_get_h_errno" + getHErrno :: IO CInt 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 @@ -37,7 +37,6 @@ , sysPosix_EAGAIN , sysPosix_EALREADY , sysPosix_EBADF - , sysPosix_EBADMSG , sysPosix_EBUSY , sysPosix_ECANCELED , sysPosix_ECHILD @@ -64,40 +63,32 @@ , sysPosix_EMFILE , sysPosix_EMLINK , sysPosix_EMSGSIZE - , sysPosix_EMULTIHOP , sysPosix_ENAMETOOLONG , sysPosix_ENETDOWN , sysPosix_ENETRESET , sysPosix_ENETUNREACH , sysPosix_ENFILE , sysPosix_ENOBUFS - , sysPosix_ENODATA , sysPosix_ENODEV , sysPosix_ENOENT , sysPosix_ENOEXEC , sysPosix_ENOLCK - , sysPosix_ENOLINK , sysPosix_ENOMEM , sysPosix_ENOMSG , sysPosix_ENOPROTOOPT , sysPosix_ENOSPC - , sysPosix_ENOSR - , sysPosix_ENOSTR , sysPosix_ENOSYS , sysPosix_ENOTCONN , sysPosix_ENOTDIR , sysPosix_ENOTEMPTY - , sysPosix_ENOTRECOVERABLE , sysPosix_ENOTSOCK , sysPosix_ENOTSUP , sysPosix_ENOTTY , sysPosix_ENXIO , sysPosix_EOPNOTSUPP , sysPosix_EOVERFLOW - , sysPosix_EOWNERDEAD , sysPosix_EPERM , sysPosix_EPIPE - , sysPosix_EPROTO , sysPosix_EPROTONOSUPPORT , sysPosix_EPROTOTYPE , sysPosix_ERANGE @@ -105,7 +96,6 @@ , sysPosix_ESPIPE , sysPosix_ESRCH , sysPosix_ESTALE - , sysPosix_ETIME , sysPosix_ETIMEDOUT , sysPosix_ETXTBSY , sysPosix_EWOULDBLOCK @@ -118,7 +108,6 @@ sysPosix_EAGAIN = (#const EAGAIN) sysPosix_EALREADY = (#const EALREADY) sysPosix_EBADF = (#const EBADF) -sysPosix_EBADMSG = (#const EBADMSG) sysPosix_EBUSY = (#const EBUSY) sysPosix_ECANCELED = (#const ECANCELED) sysPosix_ECHILD = (#const ECHILD) @@ -145,40 +134,32 @@ sysPosix_EMFILE = (#const EMFILE) sysPosix_EMLINK = (#const EMLINK) sysPosix_EMSGSIZE = (#const EMSGSIZE) -sysPosix_EMULTIHOP = (#const EMULTIHOP) sysPosix_ENAMETOOLONG = (#const ENAMETOOLONG) sysPosix_ENETDOWN = (#const ENETDOWN) sysPosix_ENETRESET = (#const ENETRESET) sysPosix_ENETUNREACH = (#const ENETUNREACH) sysPosix_ENFILE = (#const ENFILE) sysPosix_ENOBUFS = (#const ENOBUFS) -sysPosix_ENODATA = (#const ENODATA) sysPosix_ENODEV = (#const ENODEV) sysPosix_ENOENT = (#const ENOENT) sysPosix_ENOEXEC = (#const ENOEXEC) sysPosix_ENOLCK = (#const ENOLCK) -sysPosix_ENOLINK = (#const ENOLINK) sysPosix_ENOMEM = (#const ENOMEM) sysPosix_ENOMSG = (#const ENOMSG) sysPosix_ENOPROTOOPT = (#const ENOPROTOOPT) sysPosix_ENOSPC = (#const ENOSPC) -sysPosix_ENOSR = (#const ENOSR) -sysPosix_ENOSTR = (#const ENOSTR) sysPosix_ENOSYS = (#const ENOSYS) sysPosix_ENOTCONN = (#const ENOTCONN) sysPosix_ENOTDIR = (#const ENOTDIR) sysPosix_ENOTEMPTY = (#const ENOTEMPTY) -sysPosix_ENOTRECOVERABLE = (#const ENOTRECOVERABLE) sysPosix_ENOTSOCK = (#const ENOTSOCK) sysPosix_ENOTSUP = (#const ENOTSUP) sysPosix_ENOTTY = (#const ENOTTY) sysPosix_ENXIO = (#const ENXIO) sysPosix_EOPNOTSUPP = (#const EOPNOTSUPP) sysPosix_EOVERFLOW = (#const EOVERFLOW) -sysPosix_EOWNERDEAD = (#const EOWNERDEAD) sysPosix_EPERM = (#const EPERM) sysPosix_EPIPE = (#const EPIPE) -sysPosix_EPROTO = (#const EPROTO) sysPosix_EPROTONOSUPPORT = (#const EPROTONOSUPPORT) sysPosix_EPROTOTYPE = (#const EPROTOTYPE) sysPosix_ERANGE = (#const ERANGE) @@ -186,12 +167,60 @@ sysPosix_ESPIPE = (#const ESPIPE) sysPosix_ESRCH = (#const ESRCH) sysPosix_ESTALE = (#const ESTALE) -sysPosix_ETIME = (#const ETIME) sysPosix_ETIMEDOUT = (#const ETIMEDOUT) sysPosix_ETXTBSY = (#const ETXTBSY) sysPosix_EWOULDBLOCK = (#const EWOULDBLOCK) sysPosix_EXDEV = (#const EXDEV) +#ifdef ENODATA +sysPosix_ENODATA :: CErrno +sysPosix_ENODATA = (#const ENODATA) +#endif + +#ifdef ENOSR +sysPosix_ENOSR :: CErrno +sysPosix_ENOSR = (#const ENOSR) +#endif + +#ifdef ENOSTR +sysPosix_ENOSTR :: CErrno +sysPosix_ENOSTR = (#const ENOSTR) +#endif + +#ifdef ETIME +sysPosix_ETIME :: CErrno +sysPosix_ETIME = (#const ETIME) +#endif + +#ifdef EBADMSG +sysPosix_EBADMSG :: CErrno +sysPosix_EBADMSG = (#const EBADMSG) +#endif + +#ifdef EMULTIHOP +sysPosix_EMULTIHOP :: CErrno +sysPosix_EMULTIHOP = (#const EMULTIHOP) +#endif + +#ifdef ENOLINK +sysPosix_ENOLINK :: CErrno +sysPosix_ENOLINK = (#const ENOLINK) +#endif + +#ifdef ENOTRECOVERABLE +sysPosix_ENOTRECOVERABLE :: CErrno +sysPosix_ENOTRECOVERABLE = (#const ENOTRECOVERABLE) +#endif + +#ifdef EOWNERDEAD +sysPosix_EOWNERDEAD :: CErrno +sysPosix_EOWNERDEAD = (#const EOWNERDEAD) +#endif + +#ifdef EPROTO +sysPosix_EPROTO :: CErrno +sysPosix_EPROTO = (#const EPROTO) +#endif sysPosix_O_RDONLY , sysPosix_O_WRONLY diff --git a/Foundation/System/Entropy.hs b/Foundation/System/Entropy.hs --- a/Foundation/System/Entropy.hs +++ b/Foundation/System/Entropy.hs @@ -27,10 +27,10 @@ #endif -- | Get some of the system entropy -getEntropy :: Int -> IO (A.UArray Word8) -getEntropy n = do - m <- A.newPinned (Size n) - bracket entropyOpen entropyClose $ \ctx -> A.withMutablePtr m $ loop ctx n +getEntropy :: Size Word8 -> IO (A.UArray Word8) +getEntropy n@(Size x) = do + m <- A.newPinned n + bracket entropyOpen entropyClose $ \ctx -> A.withMutablePtr m $ loop ctx x A.unsafeFreeze m where loop :: EntropyCtx -> Int -> Ptr Word8 -> IO () @@ -39,5 +39,5 @@ let chSz = min entropyMaximumSize i r <- entropyGather ctx p chSz if r - then loop ctx (n-chSz) (p `plusPtr` chSz) + then loop ctx (i-chSz) (p `plusPtr` chSz) else throwIO EntropySystemMissing diff --git a/Foundation/System/Info.hs b/Foundation/System/Info.hs --- a/Foundation/System/Info.hs +++ b/Foundation/System/Info.hs @@ -29,16 +29,9 @@ import qualified Data.Version import Data.Data import qualified GHC.Conc -import Foundation.String -import Foundation.Internal.Base - -#ifdef ARCH_IS_UNKNOWN_ENDIAN -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr (castPtr) -import Foreign.Storable (poke, peek) -import Data.Word (Word8, Word32) -import System.IO.Unsafe (unsafePerformIO) -#endif +import Foundation.Internal.Base +import Foundation.Primitive.Endianness (Endianness(..), endianness) +import Foundation.String data OS = Windows @@ -54,7 +47,7 @@ -- -- This function uses the `base`'s `System.Info.os` function. -- -os :: Either String OS +os :: Either [Char] OS os = case System.Info.os of "darwin" -> Right OSX "mingw32" -> Right Windows @@ -63,7 +56,7 @@ "openbsd" -> Right BSD "netbsd" -> Right BSD "freebsd" -> Right BSD - str -> Left $ fromList str + str -> Left str -- | Enumeration of the known GHC supported architecture. -- @@ -85,7 +78,7 @@ -- -- This function uses the `base`'s `System.Info.arch` function. -- -arch :: Either String Arch +arch :: Either [Char] Arch arch = case System.Info.arch of "i386" -> Right I386 "x86_64" -> Right X86_64 @@ -96,7 +89,7 @@ "sparc64" -> Right Sparc64 "arm" -> Right ARM "aarch64" -> Right ARM64 - str -> Left $ fromList str + str -> Left str -- | get the compiler name -- @@ -108,32 +101,3 @@ -- | returns the number of CPUs the machine has cpus :: IO Int cpus = GHC.Conc.getNumProcessors - -data Endianness - = LittleEndian - | BigEndian - deriving (Eq, Show) - --- | endianness of the current architecture -endianness :: Endianness -#ifdef ARCH_IS_LITTLE_ENDIAN -endianness = LittleEndian -#elif ARCH_IS_BIG_ENDIAN -endianness = BigEndian -#else --- ! ARCH_IS_UNKNOWN_ENDIAN -endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input - where - input :: Word32 - input = 0x01020304 -{-# NOINLINE endianness #-} - -word32ToByte :: Word32 -> IO Word8 -word32ToByte word = alloca $ \wordPtr -> do - poke wordPtr word - peek (castPtr wordPtr) - -bytesToEndianness :: Word8 -> Endianness -bytesToEndianness 1 = BigEndian -bytesToEndianness _ = LittleEndian -#endif diff --git a/Foundation/UUID.hs b/Foundation/UUID.hs new file mode 100644 --- /dev/null +++ b/Foundation/UUID.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE UnboxedTuples #-} +module Foundation.UUID + ( UUID(..) + , nil + , fromBinary + ) where + +import Foundation.Internal.Base +import Foundation.Class.Storable +import Foundation.Hashing.Hashable +import Foundation.Bits +import Foundation.Primitive +import Foundation.Primitive.Base16 +import Foundation.Primitive.IntegralConv +import qualified Foundation.Array.Unboxed as UA + +data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + deriving (Eq,Ord,Typeable) +instance Show UUID where + show = toLString +instance Hashable UUID where + hashMix (UUID a b) = hashMix a . hashMix b +instance Storable UUID where + peek p = UUID <$> (fromBE <$> peekOff ptr 0) + <*> (fromBE <$> peekOff ptr 1) + where ptr = castPtr p :: Ptr (BE Word64) + poke p (UUID a b) = do + pokeOff ptr 0 (toBE a) + pokeOff ptr 1 (toBE b) + where ptr = castPtr p :: Ptr (BE Word64) +instance StorableFixed UUID where + size _ = 16 + alignment _ = 8 + +withComponent :: UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a +withComponent (UUID a b) f = f x1 x2 x3 x4 x5 + where + !x1 = integralDownsize (a .>>. 32) + !x2 = integralDownsize ((a .>>. 16) .&. 0xffff) + !x3 = integralDownsize (a .&. 0xffff) + !x4 = integralDownsize (b .>>. 48) + !x5 = (b .&. 0x0000ffffffffffff) +{-# INLINE withComponent #-} + +toLString :: UUID -> [Char] +toLString uuid = withComponent uuid $ \x1 x2 x3 x4 x5 -> + hexWord_4 x1 $ addDash $ hexWord_2 x2 $ addDash $ hexWord_2 x3 $ addDash $ hexWord_2 x4 $ addDash $ hexWord64_6 x5 [] + where + addDash = (:) '-' + hexWord_2 w l = case hexWord16 w of + (c1,c2,c3,c4) -> c1:c2:c3:c4:l + hexWord_4 w l = case hexWord32 w of + (c1,c2,c3,c4,c5,c6,c7,c8) -> c1:c2:c3:c4:c5:c6:c7:c8:l + hexWord64_6 w l = case word64ToWord32s w of + (# wHigh, wLow #) -> hexWord_2 (integralDownsize wHigh) $ hexWord_4 wLow l + +nil :: UUID +nil = UUID 0 0 + +fromBinary :: UA.UArray Word8 -> Maybe UUID +fromBinary ba + | UA.length ba /= 16 = Nothing + | otherwise = Just $ UUID w0 w1 + where + w0 = (b15 .<<. 56) .|. (b14 .<<. 48) .|. (b13 .<<. 40) .|. (b12 .<<. 32) .|. + (b11 .<<. 24) .|. (b10 .<<. 16) .|. (b9 .<<. 8) .|. b8 + w1 = (b7 .<<. 56) .|. (b6 .<<. 48) .|. (b5 .<<. 40) .|. (b4 .<<. 32) .|. + (b3 .<<. 24) .|. (b2 .<<. 16) .|. (b1 .<<. 8) .|. b0 + + b0 = integralUpsize (UA.unsafeIndex ba 0) + b1 = integralUpsize (UA.unsafeIndex ba 1) + b2 = integralUpsize (UA.unsafeIndex ba 2) + b3 = integralUpsize (UA.unsafeIndex ba 3) + b4 = integralUpsize (UA.unsafeIndex ba 4) + b5 = integralUpsize (UA.unsafeIndex ba 5) + b6 = integralUpsize (UA.unsafeIndex ba 6) + b7 = integralUpsize (UA.unsafeIndex ba 7) + b8 = integralUpsize (UA.unsafeIndex ba 8) + b9 = integralUpsize (UA.unsafeIndex ba 9) + b10 = integralUpsize (UA.unsafeIndex ba 10) + b11 = integralUpsize (UA.unsafeIndex ba 11) + b12 = integralUpsize (UA.unsafeIndex ba 12) + b13 = integralUpsize (UA.unsafeIndex ba 13) + b14 = integralUpsize (UA.unsafeIndex ba 14) + b15 = integralUpsize (UA.unsafeIndex ba 15) diff --git a/benchs/Sys.hs b/benchs/Sys.hs --- a/benchs/Sys.hs +++ b/benchs/Sys.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE OverloadedStrings #-} module Sys ( benchSys ) where @@ -16,7 +17,8 @@ instance RandomGen NullRandom where randomNew = return NullRandom - randomGenerate n r = (fromList (Prelude.replicate n 0), r) + randomNewFrom = error "no randomNewFrom" + randomGenerate (Size n) r = (fromList (Prelude.replicate n 0), r) benchSys = [ bgroup "Random" @@ -25,11 +27,11 @@ , bench "Entropy-1024" $ whnfIO $ getEntropy 1024 ] , bgroup "RNGv1" - [ bench "Entropy-1" $ benchRandom 1 randomNew (Proxy :: Proxy RNGv1) - , bench "Entropy-1024" $ benchRandom 1024 randomNew (Proxy :: Proxy RNGv1) - , bench "Entropy-1M" $ benchRandom (1024 * 1024) randomNew (Proxy :: Proxy RNGv1) + [ bench "Entropy-1" $ benchRandom 1 randomNew (Proxy :: Proxy RNGv1) + , bench "Entropy-1024" $ benchRandom 1024 randomNew (Proxy :: Proxy RNGv1) + , bench "Entropy-1M" $ benchRandom (Size (1024 * 1024)) randomNew (Proxy :: Proxy RNGv1) ] ] -benchRandom :: RandomGen rng => Int -> MonadRandomState NullRandom rng -> Proxy rng -> Benchmarkable +benchRandom :: RandomGen rng => Size Word8 -> MonadRandomState NullRandom rng -> Proxy rng -> Benchmarkable benchRandom n rNew _ = whnf (fst . randomGenerate n) (fst $ withRandomGenerator NullRandom rNew) diff --git a/cbits/foundation_network.c b/cbits/foundation_network.c new file mode 100644 --- /dev/null +++ b/cbits/foundation_network.c @@ -0,0 +1,17 @@ +#include "foundation_system.h" + +#if defined(FOUNDATION_SYSTEM_WINDOWS) +# include +#else +# include "netdb.h" +#endif + + +int foundation_network_get_h_errno(void) +{ +#if defined(FOUNDATION_SYSTEM_WINDOWS) + return WSAGetLastError(); +#else + return h_errno; +#endif +} diff --git a/foundation.cabal b/foundation.cabal --- a/foundation.cabal +++ b/foundation.cabal @@ -1,5 +1,5 @@ Name: foundation -Version: 0.0.4 +Version: 0.0.5 Synopsis: Alternative prelude with batteries and no dependencies Description: A custom prelude with no dependencies apart from base. @@ -30,7 +30,7 @@ Homepage: https://github.com/haskell-foundation/foundation Bug-Reports: https://github.com/haskell-foundation/foundation/issues Cabal-Version: >=1.10 -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 extra-source-files: README.md cbits/*.h @@ -76,10 +76,13 @@ Foundation.Monad.State Foundation.Network.IPv4 Foundation.Network.IPv6 + Foundation.Network.HostName Foundation.System.Info Foundation.Strict Foundation.Parser Foundation.Random + Foundation.Check + Foundation.UUID Foundation.System.Entropy Foundation.System.Bindings Other-modules: Foundation.Boot.Builder @@ -98,6 +101,9 @@ Foundation.Hashing.SipHash Foundation.Hashing.Hasher Foundation.Hashing.Hashable + Foundation.Check.Gen + Foundation.Check.Arbitrary + Foundation.Check.Property Foundation.Collection.Buildable Foundation.Collection.List Foundation.Collection.Element @@ -110,6 +116,7 @@ Foundation.Collection.Foldable Foundation.Collection.Mutable Foundation.Collection.Zippable + Foundation.Collection.Mappable Foundation.Conduit.Internal Foundation.Internal.Base Foundation.Internal.ByteSwap @@ -138,6 +145,7 @@ Foundation.Primitive.Types Foundation.Primitive.Monad Foundation.Primitive.Utils + Foundation.Primitive.IntegralConv Foundation.Primitive.FinalPtr Foundation.Monad.MonadIO Foundation.Monad.Exception @@ -155,9 +163,11 @@ Foundation.Foreign.MemoryMap.Types Foundation.Partial Foundation.System.Entropy.Common + Foundation.System.Bindings.Network include-dirs: cbits C-sources: cbits/foundation_random.c + cbits/foundation_network.c if os(windows) Exposed-modules: Foundation.System.Bindings.Windows @@ -176,6 +186,8 @@ if impl(ghc >= 7.10) Exposed-modules: Foundation.Tuple.Nth + Foundation.List.SList + Foundation.Primitive.Nat Default-Extensions: NoImplicitPrelude RebindableSyntax @@ -239,13 +251,28 @@ if impl(ghc >= 8.0) ghc-options: -Wno-redundant-constraints +Test-Suite check-foundation + type: exitcode-stdio-1.0 + hs-source-dirs: tests + Main-is: Checks.hs + Other-modules: + Default-Extensions: NoImplicitPrelude + RebindableSyntax + OverloadedStrings + Build-Depends: base >= 3 && < 5 + , foundation + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + default-language: Haskell2010 + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints + Test-Suite doctest type: exitcode-stdio-1.0 hs-source-dirs: tests default-language: Haskell2010 Main-is: DocTest.hs Build-Depends: base >= 3 && < 5 - , doctest >= 0.11 + , doctest >= 0.9 Default-Extensions: NoImplicitPrelude RebindableSyntax if impl(ghc < 7.6) diff --git a/tests/Checks.hs b/tests/Checks.hs new file mode 100644 --- /dev/null +++ b/tests/Checks.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Foundation +import Foundation.Check + +testAdditive :: forall a . (Eq a, Additive a, Arbitrary a) => Proxy a -> Test +testAdditive _ = Group "Additive" + [ Property "eq" $ azero === (azero :: a) + , Property "a + azero == a" $ \(v :: a) -> v + azero === v + , Property "azero + a == a" $ \(v :: a) -> azero + v === v + , Property "a + b == b + a" $ \(v1 :: a) v2 -> v1 + v2 === v2 + v1 + ] + +main = defaultMain $ Group "foundation" + [ Group "Numerical" + [ Group "Int" + [ testAdditive (Proxy :: Proxy Int) + ] + , Group "Word64" + [ testAdditive (Proxy :: Proxy Word64) + ] +{- + , Group "Natural" + [ testAdditive (Proxy :: Proxy Natural) + ] +-} + ] + ] diff --git a/tests/Imports.hs b/tests/Imports.hs --- a/tests/Imports.hs +++ b/tests/Imports.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Imports ( module X , testCase @@ -10,19 +11,33 @@ , NonZero(..) , (===?) , diffList + , assertEq + , assertEq' ) where import Foundation import Test.Tasty as X hiding (testGroup) import Test.Tasty.QuickCheck as X (Arbitrary(..), Gen, suchThat, Property, (===), (==>) - , Small(..), QuickCheckVerbose(..), QuickCheckTests(..) + , Small(..), QuickCheckTests(..) , forAll, vectorOf, frequency, choose, elements) +#if MIN_VERSION_tasty_quickcheck(0,8,4) +import Test.Tasty.QuickCheck as X (QuickCheckVerbose(..)) +#endif import Test.Tasty.HUnit as X hiding (testCase, assert, assertFailure) import Test.QuickCheck.Monadic as X import qualified Test.Tasty as Y import qualified Test.Tasty.QuickCheck as Y import qualified Test.Tasty.HUnit as Y + +assertEq :: (Eq a, Show a) => a -> a -> Bool +assertEq got expected + | got == expected = True + | otherwise = error ("got: " <> show got <> " expected: " <> show expected) +assertEq' :: (Eq a, Show a) => a -> a -> X.Assertion +assertEq' got expected + | got == expected = return () + | otherwise = error ("got: " <> show got <> " expected: " <> show expected) testCase :: String -> X.Assertion -> X.TestTree testCase x f = Y.testCase (toList x) f diff --git a/tests/Test/Foundation/Collection.hs b/tests/Test/Foundation/Collection.hs --- a/tests/Test/Foundation/Collection.hs +++ b/tests/Test/Foundation/Collection.hs @@ -11,8 +11,7 @@ import qualified Prelude -import Test.Tasty -import Test.Tasty.QuickCheck hiding (getNonEmpty) +import Imports import Foundation import Foundation.Collection @@ -122,7 +121,7 @@ , Eq (Element a) , Ord a, Ord (Item a) ) - => LString + => String -> Proxy a -> Gen (Element a) -> TestTree @@ -164,10 +163,20 @@ withListAndElement = forAll ((,) <$> generateListOfElement genElement <*> genElement) withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) 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 + -> TestTree +testSplitOn _ predicate col = testCase "splitOn (const True) mempty == [mempty]" $ + assertEq' (splitOn predicate col) [col] + testSequentialOps :: ( Sequential a , Show a, Show (Element a) , Eq (Element a) - , Ord a, Ord (Item a) + , Eq a, Ord a, Ord (Item a), Show a ) => Proxy a -> Gen (Element a) @@ -194,6 +203,13 @@ , testProperty "init" $ withNonEmptyElements $ \els -> toList (init $ fromListNonEmptyP proxy els) === init els , testProperty "splitOn" $ withElements2E $ \(l, ch) -> fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l + , testSplitOn proxy (\_ -> True) mempty + , testProperty "intercalate c (splitOn (c ==) col) == col" $ withElements2E $ \(c, ch) -> + intercalate [ch] (splitOn (== ch) c) === c + , testProperty "intercalate c (splitOn (c ==) (col ++ [c]) == (col ++ [c])" $ withElements2E $ \(c, ch) -> + intercalate [ch] (splitOn (== ch) $ snoc c ch) === (snoc c ch) + , testProperty "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) , testProperty "intersperse" $ withElements2E $ \(l, c) -> toList (intersperse c (fromListP proxy l)) === intersperse c l , testProperty "intercalate" $ withElements2E $ \(l, c) -> diff --git a/tests/Test/Foundation/Misc.hs b/tests/Test/Foundation/Misc.hs --- a/tests/Test/Foundation/Misc.hs +++ b/tests/Test/Foundation/Misc.hs @@ -1,15 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} module Test.Foundation.Misc ( testHexadecimal + , testUUID ) where import Foundation import Test.Tasty import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic import Foundation.Array.Internal (toHexadecimal) import Test.Foundation.Collection (fromListP, toListP) +import qualified Foundation.UUID as UUID + hex :: [Word8] -> [Word8] hex = loop where @@ -23,6 +26,11 @@ (q,r) = x `divMod` 16 testHexadecimal = testGroup "hexadecimal" - [ testProperty "UArray(W8)" $ \l -> + [ testProperty "UArray(W8)" $ \l -> toList (toHexadecimal (fromListP (Proxy :: Proxy (UArray Word8)) l)) == hex l + ] + +testUUID = testGroup "UUID" + [ testProperty "show" $ show (UUID.nil) === "00000000-0000-0000-0000-000000000000" + , testProperty "show-bin" $ fmap show (UUID.fromBinary (fromList [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16])) === Just "100f0e0d-0c0b-0a09-0807-060504030201" ] diff --git a/tests/Test/Foundation/Random.hs b/tests/Test/Foundation/Random.hs --- a/tests/Test/Foundation/Random.hs +++ b/tests/Test/Foundation/Random.hs @@ -11,7 +11,7 @@ import Foundation.Collection import Foundation.System.Entropy import Foundation.Random -import Control.Monad +import Control.Monad (unless) import qualified Prelude import qualified Data.List import GHC.ST diff --git a/tests/Test/Foundation/String.hs b/tests/Test/Foundation/String.hs --- a/tests/Test/Foundation/String.hs +++ b/tests/Test/Foundation/String.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module Test.Foundation.String ( testStringRefs ) where diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module Main where import Control.Monad @@ -74,11 +75,7 @@ --stringEq :: Eq a => (b -> a) -> (String -> b) -> (LString -> a) -> LUString -> Bool --stringEq back f g s = -assertEq :: (Eq a, Show a) => a -> a -> Bool -assertEq got expected - | got == expected = True - | otherwise = error ("got: " <> show got <> " expected: " <> show expected) - +#if MIN_VERSION_tasty_quickcheck(0,8,4) -- | Set in front of tests to make them verbose qcv :: TestTree -> TestTree qcv = adjustOption (\(QuickCheckVerbose _) -> QuickCheckVerbose True) @@ -90,7 +87,7 @@ -- | Scale the number of tests qcnScale :: Int -> TestTree -> TestTree qcnScale n = adjustOption (\(QuickCheckTests actual) -> QuickCheckTests (actual * n)) - +#endif testCaseFilePath :: [TestTree] testCaseFilePath = Prelude.map (makeTestCases . (\x -> (show x, x))) @@ -325,6 +322,25 @@ , testNetworkIPv4 , testNetworkIPv6 , testHexadecimal + , testUUID + , testGroup "Issues" + [ testGroup "218" + [ testCase "Foundation Strings" $ + let str1 = "aa9a9\154" :: String + str2 = "a9\154" :: String + Just x = uncons $ snd $ breakElem '9' str1 + x1 = breakElem '9' $ snd x + x2 = breakElem '9' str2 + in if assertEq x1 x2 then return () else error "failed..." + , testCase "Lazy Strings" $ + let str1 = "aa9a9\154" :: [Char] + str2 = "a9\154" :: [Char] + Just x = uncons $ snd $ breakElem '9' str1 + x1 = breakElem '9' $ snd x + x2 = breakElem '9' str2 + in if assertEq x1 x2 then return () else error "failed..." + ] + ] ] testCaseModifiedUTF8 :: [Char] -> String -> Assertion