foundation 0.0.4 → 0.0.5

raw patch · 45 files changed

+1799/−143 lines, 45 filesdep ~basedep ~doctestPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, doctest

API changes (from Hackage documentation)

Files

• Foundation/Array/Boxed.hs +1/−1
• Foundation/Array/Chunked/Unboxed.hs +5/−11
• Foundation/Array/Unboxed.hs +7/−6
• Foundation/Check.hs +132/−0
• Foundation/Check/Arbitrary.hs +60/−0
• Foundation/Check/Gen.hs +73/−0
• Foundation/Check/Property.hs +33/−0
• Foundation/Class/Storable.hs +46/−0
• Foundation/Collection.hs +6/−0
• Foundation/Collection/Buildable.hs +9/−0
• Foundation/Collection/InnerFunctor.hs +1/−1
• Foundation/Collection/List.hs +1/−1
• Foundation/Collection/Mappable.hs +104/−0
• Foundation/Hashing/FNV.hs +8/−0
• Foundation/Hashing/Hasher.hs +7/−1
• Foundation/Hashing/SipHash.hs +5/−0
• Foundation/Internal/Base.hs +1/−0
• Foundation/List/SList.hs +187/−0
• Foundation/Monad.hs +9/−1
• Foundation/Network/HostName.hsc +169/−0
• Foundation/Network/IPv4.hs +19/−1
• Foundation/Network/IPv6.hs +10/−1
• Foundation/Primitive.hs +6/−0
• Foundation/Primitive/Base16.hs +34/−7
• Foundation/Primitive/Endianness.hs +43/−2
• Foundation/Primitive/IntegralConv.hs +260/−0
• Foundation/Primitive/Nat.hs +119/−0
• Foundation/Primitive/Types.hs +69/−1
• Foundation/Random.hs +24/−8
• Foundation/String/UTF8.hs +7/−11
• Foundation/System/Bindings/Network.hsc +45/−0
• Foundation/System/Bindings/Posix.hsc +49/−20
• Foundation/System/Entropy.hs +5/−5
• Foundation/System/Info.hs +7/−43
• Foundation/UUID.hs +85/−0
• benchs/Sys.hs +7/−5
• cbits/foundation_network.c +17/−0
• foundation.cabal +30/−3
• tests/Checks.hs +29/−0
• tests/Imports.hs +16/−1
• tests/Test/Foundation/Collection.hs +20/−4
• tests/Test/Foundation/Misc.hs +10/−2
• tests/Test/Foundation/Random.hs +1/−1
• tests/Test/Foundation/String.hs +1/−0
• tests/Tests.hs +22/−6

@@ -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

@@ -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)

@@ -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)

@@ -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"

@@ -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

@@ -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

@@ -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 ===

@@ -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)

@@ -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

@@ -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

@@ -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]

@@ -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 =

@@ -0,0 +1,104 @@+-- |+-- Module      : Foundation.Primitive.Mappable+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- 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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,187 @@+-- |+-- Module      : Foundation.List.SList+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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

@@ -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)

@@ -0,0 +1,169 @@+-- |+-- Module      : Foundation.Network.HostName+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- 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 <winsock2.h>+#else+# include <netdb.h>+# include <netinet/in.h>+# include <sys/socket.h>+#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)

@@ -1,8 +1,18 @@+-- |+-- Module      : Foundation.Network.IPv4+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- 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

@@ -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 --

@@ -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

@@ -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\

@@ -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

@@ -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

@@ -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

@@ -1,4 +1,3 @@--- | -- Module      : Foundation.Primitive.Types -- License     : BSD-style -- Maintainer  : Vincent Hanquez <vincent@snarc.org>@@ -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 #-}

@@ -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)

@@ -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

@@ -0,0 +1,45 @@+-- |+-- Module      :  Foundation.System.Bindings.HostName+-- License     :  BSD-style+-- Maintainer  :  Nicolas Di Prima <nicolas@primetype.co.uk>+-- 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 <winsock2.h>+#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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -0,0 +1,17 @@+#include "foundation_system.h"++#if defined(FOUNDATION_SYSTEM_WINDOWS)+# include <winsock2.h>+#else+# include "netdb.h"+#endif+++int foundation_network_get_h_errno(void)+{+#if defined(FOUNDATION_SYSTEM_WINDOWS)+  return WSAGetLastError();+#else+  return h_errno;+#endif+}

@@ -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)

@@ -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)+            ]+-}+        ]+    ]

@@ -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

@@ -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) ->

@@ -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"     ]

@@ -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

@@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE OverloadedStrings   #-} module Test.Foundation.String     ( testStringRefs     ) where

@@ -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