foundation-0.0.23/Foundation/0000755000000000000000000000000013425601061014234 5ustar0000000000000000foundation-0.0.23/Foundation/Array/0000755000000000000000000000000013415353646015326 5ustar0000000000000000foundation-0.0.23/Foundation/Array/Chunked/0000755000000000000000000000000013415353646016707 5ustar0000000000000000foundation-0.0.23/Foundation/Check/0000755000000000000000000000000013415353646015265 5ustar0000000000000000foundation-0.0.23/Foundation/Class/0000755000000000000000000000000013415353646015315 5ustar0000000000000000foundation-0.0.23/Foundation/Collection/0000755000000000000000000000000013415353646016343 5ustar0000000000000000foundation-0.0.23/Foundation/Conduit/0000755000000000000000000000000013415353646015655 5ustar0000000000000000foundation-0.0.23/Foundation/Foreign/0000755000000000000000000000000013415353646015641 5ustar0000000000000000foundation-0.0.23/Foundation/Foreign/MemoryMap/0000755000000000000000000000000013415353646017547 5ustar0000000000000000foundation-0.0.23/Foundation/Format/0000755000000000000000000000000013415353646015500 5ustar0000000000000000foundation-0.0.23/Foundation/Format/CSV/0000755000000000000000000000000013415353646016133 5ustar0000000000000000foundation-0.0.23/Foundation/Hashing/0000755000000000000000000000000013415353646015631 5ustar0000000000000000foundation-0.0.23/Foundation/IO/0000755000000000000000000000000013415353646014557 5ustar0000000000000000foundation-0.0.23/Foundation/List/0000755000000000000000000000000013415353646015163 5ustar0000000000000000foundation-0.0.23/Foundation/Math/0000755000000000000000000000000013415353646015141 5ustar0000000000000000foundation-0.0.23/Foundation/Monad/0000755000000000000000000000000013415353646015306 5ustar0000000000000000foundation-0.0.23/Foundation/Network/0000755000000000000000000000000013425751207015675 5ustar0000000000000000foundation-0.0.23/Foundation/Numerical/0000755000000000000000000000000013415353646016167 5ustar0000000000000000foundation-0.0.23/Foundation/Random/0000755000000000000000000000000013415353646015470 5ustar0000000000000000foundation-0.0.23/Foundation/String/0000755000000000000000000000000013415353646015516 5ustar0000000000000000foundation-0.0.23/Foundation/System/0000755000000000000000000000000013415353646015534 5ustar0000000000000000foundation-0.0.23/Foundation/System/Bindings/0000755000000000000000000000000013415353646017271 5ustar0000000000000000foundation-0.0.23/Foundation/System/Entropy/0000755000000000000000000000000013415353646017174 5ustar0000000000000000foundation-0.0.23/Foundation/Time/0000755000000000000000000000000013415353646015146 5ustar0000000000000000foundation-0.0.23/Foundation/Timing/0000755000000000000000000000000013415353646015477 5ustar0000000000000000foundation-0.0.23/Foundation/Tuple/0000755000000000000000000000000013415353646015341 5ustar0000000000000000foundation-0.0.23/Foundation/VFS/0000755000000000000000000000000013415353646014706 5ustar0000000000000000foundation-0.0.23/benchs/0000755000000000000000000000000013415353646013404 5ustar0000000000000000foundation-0.0.23/benchs/BenchUtil/0000755000000000000000000000000013415353646015261 5ustar0000000000000000foundation-0.0.23/benchs/Fake/0000755000000000000000000000000013415353646014252 5ustar0000000000000000foundation-0.0.23/cbits/0000755000000000000000000000000013415353646013246 5ustar0000000000000000foundation-0.0.23/tests/0000755000000000000000000000000013415353646013304 5ustar0000000000000000foundation-0.0.23/tests/Scripts/0000755000000000000000000000000013415353646014733 5ustar0000000000000000foundation-0.0.23/tests/Test/0000755000000000000000000000000013415353646014223 5ustar0000000000000000foundation-0.0.23/tests/Test/Basement/0000755000000000000000000000000013415353646015761 5ustar0000000000000000foundation-0.0.23/tests/Test/Checks/0000755000000000000000000000000013415353646015423 5ustar0000000000000000foundation-0.0.23/tests/Test/Checks/Property/0000755000000000000000000000000013415353646017247 5ustar0000000000000000foundation-0.0.23/tests/Test/Data/0000755000000000000000000000000013415353646015074 5ustar0000000000000000foundation-0.0.23/tests/Test/Foundation/0000755000000000000000000000000013415353646016331 5ustar0000000000000000foundation-0.0.23/tests/Test/Foundation/Format/0000755000000000000000000000000013415353646017561 5ustar0000000000000000foundation-0.0.23/tests/Test/Foundation/Network/0000755000000000000000000000000013415353646017762 5ustar0000000000000000foundation-0.0.23/tests/Test/Foundation/Primitive/0000755000000000000000000000000013415353646020301 5ustar0000000000000000foundation-0.0.23/tests/Test/Foundation/String/0000755000000000000000000000000013415353646017577 5ustar0000000000000000foundation-0.0.23/Foundation.hs0000644000000000000000000001332013415353646014603 0ustar0000000000000000-- | -- Module : Foundation -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- I tried to picture clusters of information -- As they moved through the computer -- What do they look like? -- -- Alternative Prelude module Foundation ( -- * Standard -- ** Operators (Prelude.$) , (Prelude.$!) , (Prelude.&&) , (Prelude.||) , (Control.Category..) -- ** Functions , Prelude.not , Prelude.otherwise , module Foundation.Tuple , Control.Category.id , Prelude.maybe , Prelude.either , Prelude.flip , Prelude.const , Basement.Imports.error , Foundation.IO.Terminal.putStr , Foundation.IO.Terminal.putStrLn --, print , getArgs , Prelude.uncurry , Prelude.curry , Data.Tuple.swap , Prelude.until , Prelude.asTypeOf , Prelude.undefined , Prelude.seq , Foundation.Primitive.NormalForm , Foundation.Primitive.deepseq , Foundation.Primitive.force -- ** Type classes , Prelude.Show , Basement.Imports.show , Prelude.Ord (..) , Prelude.Eq (..) , Prelude.Bounded (..) , Prelude.Enum (..) , Prelude.Functor (..) , Integral (..) , Fractional (..) , HasNegation (..) , Basement.Compat.Bifunctor.Bifunctor (..) , Control.Applicative.Applicative (..) , Prelude.Monad (..) , (Control.Monad.=<<) --, Foundation.String.IsString (..) , IsString(..) , IsList(..) -- ** Numeric type classes , Foundation.Numerical.IsIntegral (..) , Foundation.Numerical.IsNatural (..) , Foundation.Numerical.Signed (..) , Foundation.Numerical.Additive (..) , Foundation.Numerical.Subtractive (..) , Foundation.Numerical.Multiplicative (..) , Foundation.Numerical.IDivisible(..) , Foundation.Numerical.Divisible(..) -- ** Data types , Prelude.Maybe (..) , Prelude.Ordering (..) , Prelude.Bool (..) , Prelude.Char , Char7 , Prelude.IO , Prelude.Either (..) -- ** Numbers , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64 , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word , Word128, Word256 , Prelude.Int , Prelude.Integer , Natural , Prelude.Rational , Prelude.Float , Prelude.Double , CountOf(..), Offset(..) , toCount , fromCount -- ** Collection types , UArray , PrimType , Array , String -- ** Numeric functions -- , (Prelude.^) , (Prelude.^^) , Prelude.fromIntegral , Prelude.realToFrac -- ** Monoids , Basement.Compat.Semigroup.Semigroup , Monoid (..) , (<>) -- ** Collection , Collection(..) , and , or , Sequential(..) , NonEmpty , nonEmpty -- ** Folds , Foldable(..) -- ** Maybe , Data.Maybe.mapMaybe , Data.Maybe.catMaybes , Data.Maybe.fromMaybe , Data.Maybe.isJust , Data.Maybe.isNothing , Data.Maybe.listToMaybe , Data.Maybe.maybeToList -- ** Either , Data.Either.partitionEithers , Data.Either.lefts , Data.Either.rights -- ** Function , Data.Function.on -- ** Applicative , (Control.Applicative.<$>) , (Control.Applicative.<|>) -- ** Monad , (Control.Monad.>=>) -- ** Exceptions , Control.Exception.Exception (..) , Data.Typeable.Typeable , Control.Exception.SomeException , Control.Exception.IOException -- ** Proxy , Data.Proxy.Proxy(..) , Data.Proxy.asProxyTypeOf -- ** Partial , Foundation.Partial.Partial , Foundation.Partial.partial , Foundation.Partial.PartialError , Foundation.Partial.fromPartial , Basement.Compat.Base.ifThenElse -- ** Old Prelude Strings as [Char] with bridge back and forth , LString ) where import qualified Prelude --import Prelude (Char, (.), Eq, Bool, IO) import Data.Monoid (Monoid (..), (<>)) import Control.Applicative import qualified Control.Category import qualified Control.Monad import qualified Control.Exception import qualified Data.Typeable import Data.Word (Word8, Word16, Word32, Word64, Word) import Data.Int (Int8, Int16, Int32, Int64) import Foundation.String (String) import Foundation.Array (UArray, Array, PrimType) import Foundation.Collection (Collection(..), and, or, Sequential(..) , NonEmpty, nonEmpty, Foldable(..)) import qualified Foundation.IO.Terminal import GHC.Exts (IsString(..)) import Basement.Compat.IsList import qualified Basement.Compat.Base (ifThenElse) import qualified Data.Proxy import qualified Foundation.Numerical import qualified Foundation.Partial import Foundation.Tuple import qualified Basement.Compat.Bifunctor import Basement.Types.OffsetSize (CountOf(..), Offset(..)) import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import Basement.Types.Char7 (Char7) import qualified Foundation.Primitive import qualified Basement.Imports import Basement.Environment (getArgs) import Basement.Compat.NumLiteral import Basement.Compat.Natural import qualified Basement.Compat.Semigroup import qualified Data.Maybe import qualified Data.Either import qualified Data.Function import qualified Data.Tuple default (Prelude.Integer, Prelude.Double) -- | Alias to Prelude String ([Char]) for compatibility purpose type LString = Prelude.String fromCount :: CountOf ty -> Prelude.Int fromCount (CountOf n) = n toCount :: Prelude.Int -> CountOf ty toCount i | i Prelude.<= 0 = CountOf 0 | Prelude.otherwise = CountOf i foundation-0.0.23/Foundation/Numerical.hs0000644000000000000000000000707113415353646016530 0ustar0000000000000000-- | -- Module : Foundation.Numerical -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Compared to the Haskell hierarchy of number classes -- this provide a more flexible approach that is closer to the -- mathematical foundation (group, field, etc) -- -- This try to only provide one feature per class, at the expense of -- the number of classes. -- {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Foundation.Numerical ( IsIntegral(..) , IsNatural(..) , Signed(..) , Additive(..) , Subtractive(..) , Multiplicative(..) , IDivisible(..) , Divisible(..) , Sign(..) , recip , IntegralRounding(..) , FloatingPoint(..) ) where import Basement.Compat.Base import Basement.Numerical.Number import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.Numerical.Multiplicative import Foundation.Numerical.Floating import qualified Prelude -- | Sign of a signed number data Sign = SignNegative | SignZero | SignPositive deriving (Eq) orderingToSign :: Ordering -> Sign orderingToSign EQ = SignZero orderingToSign GT = SignNegative orderingToSign LT = SignPositive -- | types that have sign and can be made absolute class Signed a where {-# MINIMAL abs, signum #-} abs :: a -> a signum :: a -> Sign instance Signed Integer where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Int where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Int8 where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Int16 where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Int32 where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Int64 where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Float where abs = Prelude.abs signum = orderingToSign . compare 0 instance Signed Double where abs = Prelude.abs signum = orderingToSign . compare 0 class IntegralRounding a where -- | Round up, to the next integral. -- -- Also known as 'ceiling' roundUp :: Integral n => a -> n -- | Round down, to the previous integral -- -- Also known as 'floor' roundDown :: Integral n => a -> n -- | Truncate to the closest integral to the fractional number -- closer to 0. -- -- This is equivalent to roundUp for negative Number -- and roundDown for positive Number roundTruncate :: Integral n => a -> n -- | Round to the nearest integral -- -- > roundNearest 3.6 -- 4 -- > roundNearest 3.4 -- 3 roundNearest :: Integral n => a -> n instance IntegralRounding Prelude.Rational where roundUp = fromInteger . Prelude.ceiling roundDown = fromInteger . Prelude.floor roundTruncate = fromInteger . Prelude.truncate roundNearest = fromInteger . Prelude.round instance IntegralRounding Prelude.Double where roundUp = fromInteger . Prelude.ceiling roundDown = fromInteger . Prelude.floor roundTruncate = fromInteger . Prelude.truncate roundNearest = fromInteger . Prelude.round instance IntegralRounding Prelude.Float where roundUp = fromInteger . Prelude.ceiling roundDown = fromInteger . Prelude.floor roundTruncate = fromInteger . Prelude.truncate roundNearest = fromInteger . Prelude.round foundation-0.0.23/Foundation/Array.hs0000644000000000000000000000132613415353646015664 0ustar0000000000000000-- | -- Module : Foundation.Array -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Simple Array and Almost-Array-like data structure -- -- Generally accessible in o(1) -- {-# LANGUAGE MagicHash #-} module Foundation.Array ( Array , MArray , UArray , MUArray , ChunkedUArray , Bitmap , MutableBitmap , PrimType -- exceptions , OutOfBound ) where import Basement.Exception import Basement.BoxedArray import Basement.UArray import Basement.UArray.Mutable import Foundation.Array.Bitmap import Foundation.Array.Chunked.Unboxed foundation-0.0.23/Foundation/Array/Internal.hs0000644000000000000000000000131013415353646017431 0ustar0000000000000000-- | -- Module : Foundation.Array.Internal -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Give access to Array non public functions which -- can be used to make certains optimisations. -- -- Most of what is available here has no guarantees of stability. -- Anything can be removed and changed. -- module Foundation.Array.Internal ( UArray(..) , fromForeignPtr , withPtr , copyToPtr , recast , toHexadecimal -- * Mutable facilities , new , newPinned , withMutablePtr ) where import Basement.UArray import Basement.UArray.Mutable hiding (copyToPtr) foundation-0.0.23/Foundation/Bits.hs0000644000000000000000000000211213415353646015501 0ustar0000000000000000-- Extra bits stuff module Foundation.Bits ( (.<<.) , (.>>.) , Bits(..) , alignRoundUp , alignRoundDown ) where import Basement.Compat.Base import Foundation.Numerical import Data.Bits -- | Unsafe Shift Left Operator (.<<.) :: Bits a => a -> Int -> a (.<<.) = unsafeShiftL -- | Unsafe Shift Right Operator (.>>.) :: Bits a => a -> Int -> a (.>>.) = unsafeShiftR -- | Round up (if needed) to a multiple of @alignment@ closst to @m@ -- -- @alignment@ needs to be a power of two -- -- alignRoundUp 16 8 = 16 -- alignRoundUp 15 8 = 16 alignRoundUp :: Int -- ^ Number to Align -> Int -- ^ Alignment (power of 2) -> Int alignRoundUp m alignment = (m + (alignment-1)) .&. complement (alignment-1) -- | Round down (if needed) to a multiple of @alignment@ closest to @m@ -- -- @alignment@ needs to be a power of two -- -- > alignRoundDown 15 8 = 8 -- > alignRoundDown 8 8 = 8 alignRoundDown :: Int -- ^ Number to Align -> Int -- ^ Alignment (power of 2) -> Int alignRoundDown m alignment = m .&. complement (alignment-1) foundation-0.0.23/Foundation/Class/Bifunctor.hs0000644000000000000000000000114613415353646017606 0ustar0000000000000000-- | -- Module : Foundation.Class.Bifunctor -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Formally, the class 'Bifunctor' represents a bifunctor -- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where both the first and second -- arguments are covariant. -- -- You can define a 'Bifunctor' by either defining 'bimap' or by -- defining both 'first' and 'second'. -- {-# LANGUAGE CPP #-} module Foundation.Class.Bifunctor ( module Basement.Compat.Bifunctor ) where import Basement.Compat.Bifunctor foundation-0.0.23/Foundation/Class/Storable.hs0000644000000000000000000002276113415353646017434 0ustar0000000000000000-- | -- Module : Foundation.Class.Storable -- License : BSD-style -- Maintainer : Haskell Foundation -- Stability : experimental -- Portability : portable -- -- -- -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Foundation.Class.Storable ( Storable(..) , StorableFixed(..) -- * Ptr , Ptr, plusPtr, castPtr -- * offset based helper , peekOff, pokeOff -- * Collection , peekArray , peekArrayEndedBy , pokeArray , pokeArrayEndedBy ) where #include "MachDeps.h" import GHC.Types (Double, Float) import Foreign.Ptr (castPtr) import qualified Foreign.Ptr import qualified Foreign.Storable (peek, poke) import Basement.Compat.Base import Basement.Compat.C.Types (CChar, CUChar) import Basement.Types.OffsetSize import Basement.Types.Word128 (Word128(..)) import Basement.Types.Word256 (Word256(..)) import Foundation.Collection import Foundation.Collection.Buildable (builderLift, build_) import Basement.PrimType import Basement.Endianness import Foundation.Numerical -- | Storable type of self determined size. -- class Storable a where peek :: Ptr a -> IO a poke :: Ptr a -> a -> IO () -- | Extending the Storable type class to the types that can be sequenced -- in a structure. -- class Storable a => StorableFixed a where size :: proxy a -> CountOf Word8 alignment :: proxy a -> CountOf Word8 plusPtr :: StorableFixed a => Ptr a -> CountOf a -> Ptr a plusPtr ptr (CountOf num) = ptr `Foreign.Ptr.plusPtr` (num * (size ptr `align` alignment ptr)) where align (CountOf sz) (CountOf a) = sz + (sz `mod` a) -- | like `peek` but at a given offset. peekOff :: StorableFixed a => Ptr a -> Offset a -> IO a peekOff ptr off = peek (ptr `plusPtr` offsetAsSize off) -- | 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)) => CountOf (Element col) -> Ptr (Element col) -> IO col peekArray (CountOf s) p = build_ 64 . builder 0 $ p 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 p = build_ 64 . builder 0 $ p 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 (sizeAsOffset $ length col) term instance Storable CChar where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable CUChar where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Char where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Double where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Float where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Int8 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Int16 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Int32 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Int64 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Word8 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable Word16 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable (BE Word16) where peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE instance Storable (LE Word16) where peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable Word32 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable (BE Word32) where peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE instance Storable (LE Word32) where peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable Word64 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable (BE Word64) where peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE instance Storable (LE Word64) where peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable Word128 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable (BE Word128) where peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE instance Storable (LE Word128) where peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable Word256 where peek (Ptr addr) = primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) instance Storable (BE Word256) where peek (Ptr addr) = BE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unBE instance Storable (LE Word256) where peek (Ptr addr) = LE <$> primAddrRead addr (Offset 0) poke (Ptr addr) = primAddrWrite addr (Offset 0) . unLE instance Storable (Ptr a) where peek = Foreign.Storable.peek poke = Foreign.Storable.poke instance StorableFixed CChar where size = const SIZEOF_CHAR alignment = const ALIGNMENT_CHAR instance StorableFixed CUChar where size = const SIZEOF_WORD8 alignment = const ALIGNMENT_WORD8 instance StorableFixed Char where size = const SIZEOF_HSCHAR alignment = const ALIGNMENT_HSCHAR instance StorableFixed Double where size = const SIZEOF_HSDOUBLE alignment = const ALIGNMENT_HSDOUBLE instance StorableFixed Float where size = const SIZEOF_HSFLOAT alignment = const ALIGNMENT_HSFLOAT instance StorableFixed Int8 where size = const SIZEOF_INT8 alignment = const ALIGNMENT_INT8 instance StorableFixed Int16 where size = const SIZEOF_INT16 alignment = const ALIGNMENT_INT16 instance StorableFixed Int32 where size = const SIZEOF_INT32 alignment = const ALIGNMENT_INT32 instance StorableFixed Int64 where size = const SIZEOF_INT64 alignment = const ALIGNMENT_INT64 instance StorableFixed Word8 where size = const SIZEOF_WORD8 alignment = const ALIGNMENT_WORD8 instance StorableFixed Word16 where size = const SIZEOF_WORD16 alignment = const ALIGNMENT_WORD16 instance StorableFixed (BE Word16) where size = const SIZEOF_WORD16 alignment = const ALIGNMENT_WORD16 instance StorableFixed (LE Word16) where size = const SIZEOF_WORD16 alignment = const ALIGNMENT_WORD16 instance StorableFixed Word32 where size = const SIZEOF_WORD32 alignment = const ALIGNMENT_WORD32 instance StorableFixed (BE Word32) where size = const SIZEOF_WORD32 alignment = const ALIGNMENT_WORD32 instance StorableFixed (LE Word32) where size = const SIZEOF_WORD32 alignment = const ALIGNMENT_WORD32 instance StorableFixed Word64 where size = const SIZEOF_WORD64 alignment = const ALIGNMENT_WORD64 instance StorableFixed (BE Word64) where size = const SIZEOF_WORD64 alignment = const ALIGNMENT_WORD64 instance StorableFixed (LE Word64) where size = const SIZEOF_WORD64 alignment = const ALIGNMENT_WORD64 instance StorableFixed Word128 where size = const 16 alignment = const 16 instance StorableFixed (BE Word128) where size = const 16 alignment = const 16 instance StorableFixed (LE Word128) where size = const 16 alignment = const 16 instance StorableFixed Word256 where size = const 32 alignment = const 32 instance StorableFixed (BE Word256) where size = const 32 alignment = const 32 instance StorableFixed (LE Word256) where size = const 32 alignment = const 32 instance StorableFixed (Ptr a) where size = const SIZEOF_HSPTR alignment = const ALIGNMENT_HSPTR foundation-0.0.23/Foundation/Conduit.hs0000644000000000000000000000374413415353646016221 0ustar0000000000000000module Foundation.Conduit ( Conduit , ResourceT , ZipSink (..) , await , awaitForever , yield , yields , yieldOr , leftover , runConduit , runConduitPure , runConduitRes , fuse , (.|) , sourceFile , sourceHandle , sinkFile , sinkHandle , sinkList , bracketConduit ) where import Foundation.Conduit.Internal import Foundation.Collection import Foundation.IO import Foundation.IO.File import Basement.Compat.Base import Foundation.Monad.Base import Foundation.Array import Foundation import System.IO (Handle) infixr 2 .| -- | Operator version of 'fuse'. (.|) :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r (.|) = fuse {-# INLINE (.|) #-} sourceFile :: MonadResource m => FilePath -> Conduit i (UArray Word8) m () sourceFile fp = bracketConduit (openFile fp ReadMode) closeFile sourceHandle sourceHandle :: MonadIO m => Handle -> Conduit i (UArray Word8) m () sourceHandle h = loop where defaultChunkSize :: Int defaultChunkSize = (32 :: Int) * 1000 - 16 loop = do arr <- liftIO (hGet h defaultChunkSize) if null arr then return () else yield arr >> loop -- | Send values downstream. yields :: (Monad m, Foldable os, Element os ~ o) => os -> Conduit i o m () -- FIXME: Should be using mapM_ once that is in Foldable, see #334 yields = foldr ((>>) . yield) (return ()) sinkFile :: MonadResource m => FilePath -> Conduit (UArray Word8) i m () sinkFile fp = bracketConduit (openFile fp WriteMode) closeFile sinkHandle sinkHandle :: MonadIO m => Handle -> Conduit (UArray Word8) o m () sinkHandle h = loop where loop = await >>= maybe (return ()) (\arr -> liftIO (hPut h arr) >> loop) sinkList :: Monad m => Conduit i o m [i] sinkList = loop id where loop front = await >>= maybe (return (front [])) (\x -> loop (front . (x:))) foundation-0.0.23/Foundation/Conduit/Textual.hs0000644000000000000000000000555313415353646017647 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Foundation.Conduit.Textual ( lines , words , fromBytes , toBytes ) where import Basement.Imports hiding (throw) import Basement.UArray (UArray) import Foundation.String (String) import Foundation.Collection import qualified Basement.String as S import Foundation.Conduit.Internal import Foundation.Monad import Data.Char (isSpace) -- | Split conduit of string to its lines -- -- This is very similar to Prelude lines except -- it work directly on Conduit -- -- Note that if the newline character is not ever appearing in the stream, -- this function will keep accumulating data until OOM -- -- TODO: make a size-limited function lines :: Monad m => Conduit String String m () lines = await >>= maybe (finish []) (go False []) where mconcatRev = mconcat . reverse finish l = if null l then return () else yield (mconcatRev l) go prevCR prevs nextBuf = do case S.breakLine nextBuf of Right (line, next) | S.null line && prevCR -> yield (mconcatRev (line : stripCRFromHead prevs)) >> go False mempty next | otherwise -> yield (mconcatRev (line : prevs)) >> go False mempty next Left lastCR -> let nextCurrent = nextBuf : prevs in await >>= maybe (finish nextCurrent) (go lastCR nextCurrent) stripCRFromHead [] = [] stripCRFromHead (x:xs) = S.revDrop 1 x:xs words :: Monad m => Conduit String String m () words = await >>= maybe (finish []) (go []) where mconcatRev = mconcat . reverse finish l = if null l then return () else yield (mconcatRev l) go prevs nextBuf = case S.dropWhile isSpace next' of rest' | null rest' -> let nextCurrent = nextBuf : prevs in await >>= maybe (finish nextCurrent) (go nextCurrent) | otherwise -> yield (mconcatRev (line : prevs)) >> go mempty rest' where (line, next') = S.break isSpace nextBuf fromBytes :: MonadThrow m => S.Encoding -> Conduit (UArray Word8) String m () fromBytes encoding = loop mempty where loop r = await >>= maybe (finish r) (go r) finish buf | null buf = return () | otherwise = case S.fromBytes encoding buf of (s, Nothing, _) -> yield s (_, Just err, _) -> throw err go current nextBuf = case S.fromBytes encoding (current `mappend` nextBuf) of (s, Nothing , r) -> yield s >> loop r (s, Just S.MissingByte, r) -> yield s >> loop r (_, Just err , _) -> throw err toBytes :: Monad m => S.Encoding -> Conduit String (UArray Word8) m () toBytes encoding = awaitForever $ \a -> pure (S.toBytes encoding a) >>= yield foundation-0.0.23/Foundation/Exception.hs0000644000000000000000000000071713415353646016547 0ustar0000000000000000module Foundation.Exception ( finally , try , SomeException ) where import Basement.Imports import Control.Exception (Exception, SomeException) import Foundation.Monad.Exception finally :: MonadBracket m => m a -> m b -> m a finally f g = generalBracket (return ()) (\() a -> g >> return a) (\() _ -> g) (const f) try :: (MonadCatch m, Exception e) => m a -> m (Either e a) try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) foundation-0.0.23/Foundation/Format/CSV.hs0000644000000000000000000000210113415353646016461 0ustar0000000000000000-- | -- Module : Foundation.Format.CSV -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- -- Provies the support for Comma Separated Value {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Format.CSV (-- * CSV CSV -- ** Builder -- *** String Bulider , csvStringBuilder , rowStringBuilder , fieldStringBuilder -- *** Block Builder , csvBlockBuilder , rowBlockBuilder , fieldBlockBuilder -- ** Conduit , rowC -- ** Parser -- *** String Bulider , file , record , record_ , field -- ** Conduit , recordC -- * Row , Row , Record(..) -- * Field , Field(..) , Escaping(..) , IsField(..) -- ** helpers , integral , float , string ) where import Foundation.Format.CSV.Types import Foundation.Format.CSV.Builder import Foundation.Format.CSV.Parser foundation-0.0.23/Foundation/String.hs0000644000000000000000000000204213415353646016050 0ustar0000000000000000-- | -- Module : Foundation.String -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Opaque packed String encoded in UTF8. -- -- The type is an instance of IsString and IsList, which allow OverloadedStrings -- for string literal, and 'fromList' to convert a [Char] (Prelude String) to a packed -- representation -- -- > {-# LANGUAGE OverloadedStrings #-} -- > s = "Hello World" :: String -- -- > s = fromList ("Hello World" :: Prelude.String) :: String -- -- Each unicode code point is represented by a variable encoding of 1 to 4 bytes, -- -- For more information about UTF8: -- module Foundation.String ( String , Encoding(..) , fromBytes , fromBytesLenient , fromBytesUnsafe , toBytes , ValidationFailure(..) , lines , words , upper , lower , replace , indices , toBase64 , toBase64URL , toBase64OpenBSD , breakLine ) where import Basement.String foundation-0.0.23/Foundation/String/Read.hs0000644000000000000000000000026513415353646016730 0ustar0000000000000000module Foundation.String.Read ( readInteger , readIntegral , readNatural , readDouble , readRational , readFloatingExact ) where import Basement.String foundation-0.0.23/Foundation/String/Builder.hs0000644000000000000000000000076213415353646017445 0ustar0000000000000000-- | -- Module : Foundation.String.Builder -- License : BSD-style -- Maintainer : Foundation -- -- String Builder -- module Foundation.String.Builder ( module Basement.String.Builder , toString ) where import Basement.String.Builder import Basement.String (String) import GHC.ST -- | run the builder and return a `String` -- -- alias to `runUnsafe` -- -- This function is not safe, prefer `run`. -- toString :: Builder -> String toString builder = runST (runUnsafe builder) foundation-0.0.23/Foundation/IO.hs0000644000000000000000000000131313415353646015111 0ustar0000000000000000-- | -- Module : Foundation.IO -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- IO Routine module Foundation.IO ( -- * Terminal Foundation.IO.Terminal.putStrLn , Foundation.IO.Terminal.putStr , Foundation.IO.Terminal.stdin , Foundation.IO.Terminal.stdout -- * File , Foundation.IO.File.IOMode(..) , Foundation.IO.File.openFile , Foundation.IO.File.closeFile , Foundation.IO.File.withFile , Foundation.IO.File.hGet , Foundation.IO.File.hPut , Foundation.IO.File.readFile ) where import qualified Foundation.IO.Terminal import qualified Foundation.IO.File foundation-0.0.23/Foundation/IO/FileMap.hs0000644000000000000000000000435613415353646016440 0ustar0000000000000000-- | -- Module : Foundation.IO.FileMap -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Note that the memory mapping is handled by the system, not at the haskell level. -- The system can modify the content of the memory as any moment under your feet. -- -- It also have the limitation of your system, no emulation or nice handling of all -- those corners cases is attempted here. -- -- for example mapping a large file (> 4G), on a 32 bits system is likely to just -- fail or returns inconsistent result. -- -- In doubt, use 'readFile' or other simple routine that brings -- the content of the file in IO. -- {-# LANGUAGE OverloadedStrings #-} module Foundation.IO.FileMap ( fileMapRead , fileMapReadWith ) where import Control.Exception import Basement.Types.OffsetSize import Basement.Imports import Foundation.VFS (FilePath) import Basement.FinalPtr import qualified Basement.UArray as V import qualified Foundation.Foreign.MemoryMap as I import qualified Prelude getSize :: I.FileMapping -> Int getSize fm | Prelude.fromIntegral (maxBound :: Int) < sz = error ("cannot map file in entirety as size overflow " <> show sz) | otherwise = Prelude.fromIntegral sz where (FileSize sz) = I.fileMappingSize fm -- | Map in memory the whole content of a file. -- -- Once the array goes out of scope, the memory get (eventually) unmap fileMapRead :: FilePath -> IO (V.UArray Word8) fileMapRead fp = do fileMapping <- I.fileMapRead fp fptr <- I.fileMappingToFinalPtr fileMapping return $ V.foreignMem fptr (CountOf $ getSize fileMapping) -- | Map in memory the whole content of a file, -- the whole map is unmapped at the end of function after the function has been called -- so any things that is still holding on to this memory will very likely trigger segfault -- or other really bad behavior. fileMapReadWith :: FilePath -> (V.UArray Word8 -> IO a) -> IO a fileMapReadWith fp f = do bracket (I.fileMapRead fp) I.fileMappingUnmap $ \fm -> do fptr <- toFinalPtr (I.fileMappingPtr fm) (\_ -> return ()) f (V.foreignMem fptr (CountOf $ getSize fm)) foundation-0.0.23/Foundation/IO/Terminal.hs0000644000000000000000000000146313415353646016672 0ustar0000000000000000-- | -- Module : Foundation.IO.Terminal -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- module Foundation.IO.Terminal ( putStrLn , putStr , stdin , stdout , getArgs , exitFailure , exitSuccess ) where import Basement.Imports import qualified Prelude import System.IO (stdin, stdout) import System.Exit import qualified System.Environment as SE (getArgs) -- | Print a string to standard output putStr :: String -> IO () putStr = Prelude.putStr . toList -- | Print a string with a newline to standard output putStrLn :: String -> IO () putStrLn = Prelude.putStrLn . toList -- | Get the arguments from the terminal command getArgs :: IO [String] getArgs = fmap fromList <$> SE.getArgs foundation-0.0.23/Foundation/VFS.hs0000644000000000000000000000114713415353646015245 0ustar0000000000000000-- | -- Module : Foundation.VFS -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- module Foundation.VFS ( Path(..) , filename , parent , prefix , suffix -- * FilePath , FilePath , FileName -- ** conversion , filePathToString , filePathToLString ) where import Foundation.VFS.Path ( Path(..) , filename, parent, suffix, prefix ) import Foundation.VFS.FilePath ( FilePath, FileName , filePathToString , filePathToLString ) foundation-0.0.23/Foundation/VFS/Path.hs0000644000000000000000000000756613415353646016154 0ustar0000000000000000-- | -- Module : Foundation.VFS.Path -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE FlexibleContexts #-} module Foundation.VFS.Path ( -- * Path class Path(..) , parent , filename , prefix , suffix ) where import Basement.Compat.Base -- $setup -- >>> import Basement.Compat.Base -- >>> import Foundation.VFS.FilePath -- >>> import Foundation.VFS.Path -- | Path type class -- -- defines the Path associated types and basic functions to implement related -- to the path manipulation -- -- # TODO, add missing enhancement: -- -- @ -- splitExtension :: PathEnt path -> (PathEnt path, PathEnt path) -- addExtension :: PathEnt path -> PathEnt path -> PathEnt path -- (<.>) :: path -> PathEnt path -> path -- (-<.>) :: path -> PathEnt path -> path -- @ -- class Path path where -- | the associated PathEntity of the given `path` -- this type is the minimal element contained in the Path -- a Path is not a collection but it is possible to see this -- associated type equivalent to the `Foundation.Collection.Element` type family type PathEnt path -- | the associated prefix of the given `path` -- -- in the case of a `Foundation.VFS.FilePath`, it is a void (i.e. `()`) -- in the case of a `Foundation.VFS.URI`, it is the schema, host, port... type PathPrefix path -- | the associated suffix of the given path -- -- in the case of the `Foundation.VFS.FilePath`, it is a void (i.e. `()`) -- in the case of the `Foundation.VFS.URI`, it is a the query, the fragment type PathSuffix path -- | join a path entity to a given path () :: path -> PathEnt path -> path -- | split the path into the associated elements splitPath :: path -> ( PathPrefix path , [PathEnt path] , PathSuffix path ) -- | build the path from the associated elements buildPath :: ( PathPrefix path , [PathEnt path] , PathSuffix path ) -> path -- | parent is only going to drop the filename. -- -- if you actually want to reference to the parent directory, simply uses: -- -- @ -- parent "." /= "." ".." -- @ -- -- >>> parent ("foo.hs" :: FilePath) -- . -- -- >>> parent ("foo/bar/baz.hs" :: FilePath) -- foo/bar parent :: Path path => path -> path parent path = buildPath (p, init ps, s) where (p, ps, s) = splitPath path -- | get the filename of the given path -- -- If there is no filename, you will receive the 'mempty' of the 'PathEnt' -- -- >>> filename ("foo.hs" :: FilePath) -- foo.hs -- -- >>> filename ("foo/bar/baz.hs" :: FilePath) -- baz.hs filename :: (Path path, Monoid (PathEnt path)) => path -> PathEnt path filename path = case ps of [] -> mempty _ -> last ps where (_, ps , _) = splitPath path -- TODO: this might be better in Sequential ? init :: [a] -> [a] init [] = [] init [_] = [] init (x:xs) = x : init xs -- TODO: this might be better in Sequential ? last :: [a] -> a last [] = undefined last [x] = x last (_:xs) = last xs -- | get the path prefix information -- -- >>> prefix ("/home/tab" :: FilePath) -- Absolute -- -- >>> prefix ("home/tab" :: FilePath) -- Relative -- -- or for URI (TODO, not yet accurate) -- -- @ -- prefix "http://github.com/vincenthz/hs-foundation?w=1" -- == URISchema http Nothing Nothing "github.com" Nothing -- @ prefix :: Path path => path -> PathPrefix path prefix p = pre where (pre, _, _) = splitPath p -- | get the path suffix information -- -- >>> suffix ("/home/tab" :: FilePath) -- () -- -- or for URI (TODO, not yet accurate) -- -- @ -- suffix "http://github.com/vincenthz/hs-foundation?w=1" -- == URISuffix (["w", "1"], Nothing) -- @ suffix :: Path path => path -> PathSuffix path suffix p = suf where (_, _, suf) = splitPath p foundation-0.0.23/Foundation/VFS/FilePath.hs0000644000000000000000000002001113415353646016730 0ustar0000000000000000-- | -- Module : Foundation.VFS.FilePath -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- -- # Opaque implementation for FilePath -- -- The underlying type of a FilePath is a `Foundation.ByteArray`. It is indeed like -- this because for some systems (Unix systems) a `FilePath` is a null -- terminated array of bytes. -- -- # FilePath and FileName for type checking validation -- -- In order to add some constraint at compile time, it is not possible to -- append (``) a `FilePath` to another `FilePath`. -- You can only append (``) a `FileName` to a given `FilePath`. -- {-# LANGUAGE CPP #-} module Foundation.VFS.FilePath ( FilePath , Relativity(..) , FileName -- * conversion , filePathToString , filePathToLString -- ** unsafe , unsafeFilePath , unsafeFileName , extension ) where import Basement.Compat.Base import Basement.Compat.Semigroup import Foundation.Collection import Foundation.Array import Foundation.String (Encoding(..), ValidationFailure, toBytes, fromBytes, String) import Foundation.VFS.Path(Path(..)) import qualified Data.List -- ------------------------------------------------------------------------- -- -- System related helpers -- -- ------------------------------------------------------------------------- -- #ifdef mingw32_HOST_OS pathSeparatorWINC :: Char pathSeparatorWINC = '\\' -- | define the Path separator for Windows systems : '\\' pathSeparatorWIN :: String pathSeparatorWIN = fromString [pathSeparatorWINC] #else pathSeparatorPOSIXC :: Char pathSeparatorPOSIXC = '/' -- | define the Path separator for POSIX systems : '/' pathSeparatorPOSIX :: String pathSeparatorPOSIX = fromString [pathSeparatorPOSIXC] #endif pathSeparatorC :: Char pathSeparator :: String #ifdef mingw32_HOST_OS pathSeparatorC = pathSeparatorWINC pathSeparator = pathSeparatorWIN #else pathSeparatorC = pathSeparatorPOSIXC pathSeparator = pathSeparatorPOSIX #endif -- ------------------------------------------------------------------------- -- -- FilePath -- -- ------------------------------------------------------------------------- -- -- | information about type of FilePath -- -- A file path being only `Relative` or `Absolute`. data Relativity = Absolute | Relative deriving (Eq, Show) -- | FilePath is a collection of FileName -- -- TODO: Eq and Ord are implemented using Show -- This is not very efficient and would need to be improved -- Also, it is possible the ordering is not necessary what we want -- in this case. -- -- A FilePath is one of the following: -- -- * An Absolute: -- * starts with one of the follwing "/" -- * A relative: -- * don't start with a "/" -- -- * authorised: -- * "/" -- * "/file/path" -- * "." -- * ".." -- * "work/haskell/hs-foundation" -- -- * unauthorised -- * "path//" data FilePath = FilePath Relativity [FileName] instance Show FilePath where show = filePathToLString instance Eq FilePath where (==) a b = (==) (show a) (show b) instance Ord FilePath where compare a b = compare (show a) (show b) -- | error associated to filepath manipulation data FilePath_Invalid = ContiguousPathSeparator -- ^ this mean there were 2 contiguous path separators. -- -- This is not valid in Foundation's FilePath specifications deriving (Typeable, Show) instance Exception FilePath_Invalid instance IsString FilePath where fromString [] = FilePath Absolute mempty fromString s@(x:xs) | hasContigueSeparators s = throw ContiguousPathSeparator | otherwise = FilePath relativity $ case relativity of Absolute -> fromString <$> splitOn isSeparator xs Relative -> fromString <$> splitOn isSeparator s where relativity :: Relativity relativity = if isSeparator x then Absolute else Relative -- | A filename (or path entity) in the FilePath -- -- * Authorised -- * "" -- * "." -- * ".." -- * "foundation" -- * Unauthorised -- * "/" -- * "file/" -- * "/file" -- * "file/path" -- data FileName = FileName (UArray Word8) deriving (Eq) -- | errors related to FileName manipulation data FileName_Invalid = ContainsNullByte -- ^ this means a null byte was found in the FileName | ContainsSeparator -- ^ this means a path separator was found in the FileName | EncodingError ValidationFailure -- ^ encoding error | UnknownTrailingBytes (UArray Word8) -- ^ some unknown trainling bytes found deriving (Typeable, Show) instance Exception FileName_Invalid instance Show FileName where show = fileNameToLString instance IsString FileName where fromString [] = FileName mempty fromString xs | hasNullByte xs = throw ContainsNullByte | hasSeparator xs = throw ContainsSeparator | otherwise = FileName $ toBytes UTF8 $ fromString xs hasNullByte :: [Char] -> Bool hasNullByte = Data.List.elem '\0' hasSeparator :: [Char] -> Bool hasSeparator = Data.List.elem pathSeparatorC isSeparator :: Char -> Bool isSeparator = (==) pathSeparatorC hasContigueSeparators :: [Char] -> Bool hasContigueSeparators [] = False hasContigueSeparators [_] = False hasContigueSeparators (x1:x2:xs) = (isSeparator x1 && x1 == x2) || hasContigueSeparators xs instance Semigroup FileName where (<>) (FileName a) (FileName b) = FileName $ a `mappend` b instance Monoid FileName where mempty = FileName mempty mappend (FileName a) (FileName b) = FileName $ a `mappend` b instance Path FilePath where type PathEnt FilePath = FileName type PathPrefix FilePath = Relativity type PathSuffix FilePath = () () = join splitPath (FilePath r xs) = (r, xs, ()) buildPath (r, xs , _) = FilePath r xs -- compare to the original , this type disallow to be able to append an absolute filepath to a filepath join :: FilePath -> FileName -> FilePath join p (FileName x) | null x = p join (FilePath r xs) x = FilePath r $ snoc xs x filePathToString :: FilePath -> String filePathToString (FilePath Absolute []) = fromString [pathSeparatorC] filePathToString (FilePath Relative []) = fromString "." filePathToString (FilePath Absolute fns) = cons pathSeparatorC $ filenameIntercalate fns filePathToString (FilePath Relative fns) = filenameIntercalate fns filenameIntercalate :: [FileName] -> String filenameIntercalate = mconcat . Data.List.intersperse pathSeparator . fmap fileNameToString -- | convert a FileName into a String -- -- This function may throw an exception associated to the encoding fileNameToString :: FileName -> String fileNameToString (FileName fp) = -- FIXME probably incorrect considering windows. -- this is just to get going to be able to be able to reuse System.IO functions which -- works on [Char] case fromBytes UTF8 fp of (s, Nothing, bs) | null bs -> s | otherwise -> throw $ UnknownTrailingBytes bs (_, Just err, _) -> throw $ EncodingError err -- | conversion of FileName into a list of Char -- -- this function may throw exceptions fileNameToLString :: FileName -> [Char] fileNameToLString = toList . fileNameToString -- | conversion of a FilePath into a list of Char -- -- this function may throw exceptions filePathToLString :: FilePath -> [Char] filePathToLString = toList . filePathToString -- | build a file path from a given list of filename -- -- this is unsafe and is mainly needed for testing purpose unsafeFilePath :: Relativity -> [FileName] -> FilePath unsafeFilePath = FilePath -- | build a file name from a given ByteArray -- -- this is unsafe and is mainly needed for testing purpose unsafeFileName :: UArray Word8 -> FileName unsafeFileName = FileName extension :: FileName -> Maybe FileName extension (FileName fn) = case splitOn (\c -> c == 0x2E) fn of [] -> Nothing [_] -> Nothing xs -> Just $ FileName $ last $ nonEmpty_ xs foundation-0.0.23/Foundation/VFS/URI.hs0000644000000000000000000000202113415353646015674 0ustar0000000000000000-- | -- Module : Foundation.VFS.URI -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- module Foundation.VFS.URI ( URI(..) , URISchema(..) , URIAuthority(..) , URIQuery(..) , URIFragment(..) , URIPath(..) ) where import Basement.Compat.Base import Foundation.VFS.Path(Path(..)) -- ------------------------------------------------------------------------- -- -- URI -- -- ------------------------------------------------------------------------- -- -- | TODO this is not implemented yet data URI = URI data URISchema = URISchema data URIAuthority = URIAuthority data URIQuery = URIQuery data URIFragment = URIFragment data URIPath = URIPath instance Path URI where type PathEnt URI = URIPath type PathPrefix URI = (URISchema, URIAuthority) type PathSuffix URI = (URIQuery, URIFragment) () = undefined splitPath = undefined buildPath = undefined foundation-0.0.23/Foundation/Math/Trigonometry.hs0000644000000000000000000000271713415353646020206 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} module Foundation.Math.Trigonometry ( Trigonometry(..) ) where import Basement.Compat.Base import qualified Prelude -- | Method to support basic trigonometric functions class Trigonometry a where -- | the famous pi value pi :: a -- | sine sin :: a -> a -- | cosine cos :: a -> a -- | tan tan :: a -> a -- | sine-1 asin :: a -> a -- | cosine-1 acos :: a -> a -- | tangent-1 atan :: a -> a -- | hyperbolic sine sinh :: a -> a -- | hyperbolic cosine cosh :: a -> a -- | hyperbolic tangent tanh :: a -> a -- | hyperbolic sine-1 asinh :: a -> a -- | hyperbolic cosine-1 acosh :: a -> a -- | hyperbolic tangent-1 atanh :: a -> a instance Trigonometry Float where pi = Prelude.pi sin = Prelude.sin cos = Prelude.cos tan = Prelude.tan asin = Prelude.asin acos = Prelude.acos atan = Prelude.atan sinh = Prelude.sinh cosh = Prelude.cosh tanh = Prelude.tanh asinh = Prelude.asinh acosh = Prelude.acosh atanh = Prelude.atanh instance Trigonometry Double where pi = Prelude.pi sin = Prelude.sin cos = Prelude.cos tan = Prelude.tan asin = Prelude.asin acos = Prelude.acos atan = Prelude.atan sinh = Prelude.sinh cosh = Prelude.cosh tanh = Prelude.tanh asinh = Prelude.asinh acosh = Prelude.acosh atanh = Prelude.atanh foundation-0.0.23/Foundation/Hashing.hs0000644000000000000000000000063413415353646016170 0ustar0000000000000000-- | -- Module : Foundation.Hashing -- License : BSD-style -- Maintainer : Foundation -- module Foundation.Hashing ( Hashable(..) , Hasher -- * Specific methods , FNV1_32 , FNV1_64 , FNV1a_32 , FNV1a_64 , Sip1_3 , Sip2_4 ) where import Foundation.Hashing.Hashable import Foundation.Hashing.Hasher import Foundation.Hashing.FNV import Foundation.Hashing.SipHash foundation-0.0.23/Foundation/Foreign.hs0000644000000000000000000000075513415353646016204 0ustar0000000000000000-- | -- Module : Foundation.Foreign -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- module Foundation.Foreign ( module Basement.FinalPtr , V.foreignMem , V.mutableForeignMem , module Basement.Compat.C.Types ) where import Basement.FinalPtr import qualified Basement.UArray as V import qualified Basement.UArray.Mutable as V import Basement.Compat.C.Types foundation-0.0.23/Foundation/Collection.hs0000644000000000000000000000270413415353646016702 0ustar0000000000000000-- | -- Module : Foundation.Collection -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Different collections (list, vector, string, ..) unified under 1 API. -- an API to rules them all, and in the darkness bind them. -- {-# LANGUAGE FlexibleInstances #-} module Foundation.Collection ( BoxedZippable(..) , Element , InnerFunctor(..) , Foldable(..) , Fold1able(..) , Mappable(..) , traverse_ , mapM_ , forM , forM_ , Collection(..) , and , or , NonEmpty , getNonEmpty , nonEmpty , nonEmpty_ , nonEmptyFmap , Sequential(..) , MutableCollection(..) , IndexedCollection(..) , KeyedCollection(..) , Zippable(..) , Buildable(..) , build_ , Builder(..) , BuildingState(..) , Copy(..) ) where import Foundation.Collection.Buildable import Foundation.Collection.Element import Foundation.Collection.Foldable import Foundation.Collection.Indexed import Foundation.Collection.InnerFunctor import Foundation.Collection.Keyed import Foundation.Collection.Mutable import Foundation.Collection.Collection import Foundation.Collection.Sequential import Foundation.Collection.Mappable import Foundation.Collection.Zippable import Foundation.Collection.Copy foundation-0.0.23/Foundation/Primitive.hs0000644000000000000000000000161613415353646016560 0ustar0000000000000000-- | -- Module : Foundation.Primitive -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- {-# LANGUAGE FlexibleInstances #-} module Foundation.Primitive ( PrimType(..) , PrimMonad(..) -- * endianess , ByteSwap , LE(..), toLE, fromLE , BE(..), toBE, fromBE -- * Integral convertion , IntegralUpsize(..) , IntegralDownsize(..) -- * Evaluation , NormalForm(..) , force , deepseq -- * These , These(..) -- * Block of memory , Block , MutableBlock -- * Ascii , Char7 , AsciiString ) where import Basement.PrimType import Basement.Types.Char7 import Basement.Types.AsciiString import Basement.Monad import Basement.Endianness import Basement.IntegralConv import Basement.NormalForm import Basement.These import Basement.Block foundation-0.0.23/Foundation/List/DList.hs0000644000000000000000000000567113415353646016547 0ustar0000000000000000-- | -- Module : Foundation.List.DList -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : statble -- Portability : portable -- -- Data structure for optimised operations (append, cons, snoc) on list -- module Foundation.List.DList ( DList ) where import Basement.Compat.Base import Basement.Compat.Semigroup import Basement.Compat.Bifunctor import Foundation.Collection newtype DList a = DList { unDList :: [a] -> [a] } deriving (Typeable) instance Eq a => Eq (DList a) where (==) dl1 dl2 = (==) (toList dl1) (toList dl2) instance Ord a => Ord (DList a) where compare dl1 dl2 = compare (toList dl1) (toList dl2) instance Show a => Show (DList a) where show = show . toList instance IsList (DList a) where type Item (DList a) = a fromList = DList . (Basement.Compat.Semigroup.<>) toList = flip unDList [] instance Semigroup (DList a) where (<>) dl1 dl2 = DList $ unDList dl1 . unDList dl2 instance Monoid (DList a) where mempty = DList id mappend dl1 dl2 = DList $ unDList dl1 . unDList dl2 instance Functor DList where fmap f = foldr (cons . f) mempty instance Applicative DList where pure = singleton (<*>) m1 m2 = m1 >>= \x1 -> m2 >>= \x2 -> return (x1 x2) instance Monad DList where (>>=) m k = foldr (mappend . k) mempty m return = singleton type instance Element (DList a) = a instance Foldable (DList a) where foldr f b = foldr f b . toList foldl' f b = foldl' f b . toList instance Collection (DList a) where null = null . toList length = length . toList elem a = elem a . toList maximum = maximum . nonEmpty_ . toList minimum = minimum . nonEmpty_ . toList all f = all f . toList any f = any f . toList instance Sequential (DList a) where take n = fromList . take n . toList revTake n = fromList . revTake n . toList drop n = fromList . drop n . toList revDrop n = fromList . revDrop n . toList splitAt n = bimap fromList fromList . splitAt n . toList splitOn f = fmap fromList . splitOn f . toList break f = bimap fromList fromList . break f . toList breakEnd f = bimap fromList fromList . breakEnd f . toList breakElem e = bimap fromList fromList . breakElem e . toList intersperse e = fromList . intersperse e . toList intercalate e = intercalate e . toList span f = bimap fromList fromList . span f . toList spanEnd f = bimap fromList fromList . spanEnd f . toList filter f = fromList . filter f . toList partition f = bimap fromList fromList . partition f . toList reverse = fromList . reverse . toList uncons dl = second fromList <$> uncons (toList dl) unsnoc dl = first fromList <$> unsnoc (toList dl) cons e dl = DList $ (:) e . unDList dl snoc dl e = DList $ unDList dl . (:) e find f = find f . toList sortBy comp = fromList . sortBy comp . toList singleton = DList . (:) replicate n e = fromList $ replicate n e foundation-0.0.23/Foundation/List/ListN.hs0000644000000000000000000000054513415353646016554 0ustar0000000000000000-- | -- Module : Foundation.List.ListN -- 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. -- module Foundation.List.ListN ( module X ) where import Basement.Sized.List as X foundation-0.0.23/Foundation/Monad.hs0000644000000000000000000000335713415353646015652 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} module Foundation.Monad ( MonadIO(..) , MonadFailure(..) , MonadThrow(..) , MonadCatch(..) , MonadBracket(..) , MonadTrans(..) , Identity(..) , replicateM ) where import Basement.Imports import Basement.Types.OffsetSize import Basement.Monad (MonadFailure(..)) import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer import Foundation.Numerical import Control.Applicative (liftA2) #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity #else import Control.Monad.Fix import Control.Monad.Zip import Basement.Compat.Base import GHC.Generics (Generic1) -- | Identity functor and monad. (a non-strict monad) -- -- @since 4.8.0.0 newtype Identity a = Identity { runIdentity :: a } deriving (Eq, Ord, Data, Generic, Generic1, Typeable) instance Functor Identity where fmap f (Identity x) = Identity (f x) instance Applicative Identity where pure = Identity Identity f <*> Identity x = Identity (f x) instance Monad Identity where return = Identity m >>= k = k (runIdentity m) instance MonadFix Identity where mfix f = Identity (fix (runIdentity . f)) instance MonadZip Identity where mzipWith f (Identity x) (Identity y) = Identity (f x y) munzip (Identity (x, y)) = (Identity x, Identity y) #endif -- | @'replicateM' n act@ performs the action @n@ times, -- gathering the results. replicateM :: Applicative m => CountOf a -> m a -> m [a] replicateM (CountOf count) f = loop count where loop cnt | cnt <= 0 = pure [] | otherwise = liftA2 (:) f (loop (cnt - 1)) {-# INLINEABLE replicateM #-} foundation-0.0.23/Foundation/Monad/Except.hs0000644000000000000000000000342613415353646017077 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} module Foundation.Monad.Except ( ExceptT(..) ) where import Basement.Imports import Basement.Compat.AMP import Foundation.Monad.Base import Foundation.Monad.Reader newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } instance Functor m => Functor (ExceptT e m) where fmap f = ExceptT . fmap (fmap f) . runExceptT instance AMPMonad m => Applicative (ExceptT e m) where pure a = ExceptT $ pure (Right a) ExceptT f <*> ExceptT v = ExceptT $ do mf <- f case mf of Left e -> pure (Left e) Right k -> do mv <- v case mv of Left e -> pure (Left e) Right x -> pure (Right (k x)) instance AMPMonad m => MonadFailure (ExceptT e m) where type Failure (ExceptT e m) = e mFail = ExceptT . pure . Left instance AMPMonad m => Monad (ExceptT e m) where return a = ExceptT $ return (Right a) m >>= k = ExceptT $ do a <- runExceptT m case a of Left e -> return (Left e) Right x -> runExceptT (k x) fail = ExceptT . fail instance (AMPMonad m, MonadFix m) => MonadFix (ExceptT e m) where mfix f = ExceptT (mfix (runExceptT . f . fromEither)) where fromEither (Right x) = x fromEither (Left _) = error "mfix (ExceptT): inner computation returned Left value" {-# INLINE mfix #-} instance MonadReader m => MonadReader (ExceptT e m) where type ReaderContext (ExceptT e m) = ReaderContext m ask = ExceptT (Right <$> ask) instance MonadTrans (ExceptT e) where lift f = ExceptT (Right <$> f) instance MonadIO m => MonadIO (ExceptT e m) where liftIO f = ExceptT (Right <$> liftIO f) foundation-0.0.23/Foundation/Monad/Reader.hs0000644000000000000000000000455313415353646017053 0ustar0000000000000000-- | -- The Reader monad transformer. -- -- This is useful to keep a non-modifiable value -- in a context {-# LANGUAGE ConstraintKinds #-} module Foundation.Monad.Reader ( -- * MonadReader MonadReader(..) , -- * ReaderT ReaderT , runReaderT ) where import Basement.Compat.Base (($), (.), const) import Basement.Compat.AMP import Foundation.Monad.Base import Foundation.Monad.Exception class AMPMonad m => MonadReader m where type ReaderContext m ask :: m (ReaderContext m) -- | Reader Transformer newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } instance Functor m => Functor (ReaderT r m) where fmap f m = ReaderT $ fmap f . runReaderT m {-# INLINE fmap #-} instance Applicative m => Applicative (ReaderT r m) where pure a = ReaderT $ const (pure a) {-# INLINE pure #-} fab <*> fa = ReaderT $ \r -> runReaderT fab r <*> runReaderT fa r {-# INLINE (<*>) #-} instance AMPMonad m => Monad (ReaderT r m) where return a = ReaderT $ const (return a) {-# INLINE return #-} ma >>= mab = ReaderT $ \r -> runReaderT ma r >>= \a -> runReaderT (mab a) r {-# INLINE (>>=) #-} instance (AMPMonad m, MonadFix m) => MonadFix (ReaderT s m) where mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r {-# INLINE mfix #-} instance MonadTrans (ReaderT r) where lift f = ReaderT $ const f {-# INLINE lift #-} instance MonadIO m => MonadIO (ReaderT r m) where liftIO f = lift (liftIO f) {-# INLINE liftIO #-} instance MonadFailure m => MonadFailure (ReaderT r m) where type Failure (ReaderT r m) = Failure m mFail e = ReaderT $ \_ -> mFail e instance MonadThrow m => MonadThrow (ReaderT r m) where throw e = ReaderT $ \_ -> throw e instance MonadCatch m => MonadCatch (ReaderT r m) where catch (ReaderT m) c = ReaderT $ \r -> m r `catch` (\e -> runReaderT (c e) r) instance MonadBracket m => MonadBracket (ReaderT r m) where generalBracket acq cleanup cleanupExcept innerAction = do c <- ask lift $ generalBracket (runReaderT acq c) (\a b -> runReaderT (cleanup a b) c) (\a exn -> runReaderT (cleanupExcept a exn) c) (\a -> runReaderT (innerAction a) c) instance AMPMonad m => MonadReader (ReaderT r m) where type ReaderContext (ReaderT r m) = r ask = ReaderT return foundation-0.0.23/Foundation/Monad/State.hs0000644000000000000000000000434713415353646016732 0ustar0000000000000000{-# LANGUAGE TupleSections #-} module Foundation.Monad.State ( -- * MonadState MonadState(..) , get , put , -- * StateT StateT , runStateT ) where import Basement.Compat.Bifunctor (first) import Basement.Compat.Base (($), (.), const) import Foundation.Monad.Base import Control.Monad ((>=>)) class Monad m => MonadState m where type State m withState :: (State m -> (a, State m)) -> m a get :: MonadState m => m (State m) get = withState $ \s -> (s, s) put :: MonadState m => State m -> m () put s = withState $ const ((), s) -- | State Transformer newtype StateT s m a = StateT { runStateT :: s -> m (a, s) } instance Functor m => Functor (StateT s m) where fmap f m = StateT $ \s1 -> (first f) `fmap` runStateT m s1 {-# INLINE fmap #-} instance (Applicative m, Monad m) => Applicative (StateT s m) where pure a = StateT $ \s -> (,s) `fmap` pure a {-# INLINE pure #-} fab <*> fa = StateT $ \s1 -> do (ab,s2) <- runStateT fab s1 (a, s3) <- runStateT fa s2 return (ab a, s3) {-# INLINE (<*>) #-} instance (Functor m, Monad m) => Monad (StateT s m) where return a = StateT $ \s -> (,s) `fmap` return a {-# INLINE return #-} ma >>= mab = StateT $ runStateT ma >=> (\(a, s2) -> runStateT (mab a) s2) {-# INLINE (>>=) #-} instance (Functor m, MonadFix m) => MonadFix (StateT s m) where mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s {-# INLINE mfix #-} instance MonadTrans (StateT s) where lift f = StateT $ \s -> f >>= return . (,s) {-# INLINE lift #-} instance (Functor m, MonadIO m) => MonadIO (StateT s m) where liftIO f = lift (liftIO f) {-# INLINE liftIO #-} instance (Functor m, MonadFailure m) => MonadFailure (StateT s m) where type Failure (StateT s m) = Failure m mFail e = StateT $ \s -> ((,s) `fmap` mFail e) instance (Functor m, MonadThrow m) => MonadThrow (StateT s m) where throw e = StateT $ \_ -> throw e instance (Functor m, MonadCatch m) => MonadCatch (StateT s m) where catch (StateT m) c = StateT $ \s1 -> m s1 `catch` (\e -> runStateT (c e) s1) instance (Functor m, Monad m) => MonadState (StateT s m) where type State (StateT s m) = s withState f = StateT $ return . f foundation-0.0.23/Foundation/Network/IPv4.hs0000644000000000000000000000560313425751207017017 0ustar0000000000000000-- | -- Module : Foundation.Network.IPv4 -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : experimental -- Portability : portable -- -- IPv4 data type -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Foundation.Network.IPv4 ( IPv4 , any, loopback , fromString, toString , fromTuple, toTuple , ipv4Parser ) where import Prelude (fromIntegral,read) import Foundation.Class.Storable import Foundation.Hashing.Hashable import Basement.Compat.Base import Data.Proxy import Foundation.String (String) import Foundation.Primitive import Basement.Bits import Foundation.Parser hiding (peek) import Foundation.Collection (Sequential, Element, elem) -- | IPv4 data type newtype IPv4 = IPv4 Word32 deriving (Eq, Ord, Typeable, Hashable) instance Show IPv4 where show = toLString instance NormalForm IPv4 where toNormalForm !_ = () instance IsString IPv4 where fromString = fromLString instance Storable IPv4 where peek ptr = IPv4 . fromBE <$> peek (castPtr ptr) poke ptr (IPv4 w) = poke (castPtr ptr) (toBE w) instance StorableFixed IPv4 where size _ = size (Proxy :: Proxy Word32) alignment _ = alignment (Proxy :: Proxy Word32) -- | "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 fromLString :: [Char] -> IPv4 fromLString = either throw id . parseOnly ipv4Parser toLString :: IPv4 -> [Char] toLString ipv4 = let (i1, i2, i3, i4) = toTuple ipv4 in show i1 <> "." <> show i2 <> "." <> show i3 <> "." <> show i4 fromTuple :: (Word8, Word8, Word8, Word8) -> IPv4 fromTuple (i1, i2, i3, i4) = IPv4 $ (w1 .<<. 24) .&. 0xFF000000 .|. (w2 .<<. 16) .&. 0x00FF0000 .|. (w3 .<<. 8) .&. 0x0000FF00 .|. w4 .&. 0x000000FF where f = fromIntegral w1, w2, w3, w4 :: Word32 w1 = f i1 w2 = f i2 w3 = f i3 w4 = f i4 toTuple :: IPv4 -> (Word8, Word8, Word8, Word8) toTuple (IPv4 w) = (f w1, f w2, f w3, f w4) where f = fromIntegral w1, w2, w3, w4 :: Word32 w1 = w .>>. 24 .&. 0x000000FF w2 = w .>>. 16 .&. 0x000000FF w3 = w .>>. 8 .&. 0x000000FF w4 = w .&. 0x000000FF -- | Parse a IPv4 address ipv4Parser :: ( ParserSource input, Element input ~ Char , Sequential (Chunk input), Element input ~ Element (Chunk input) ) => Parser input IPv4 ipv4Parser = do i1 <- takeAWord8 <* element '.' i2 <- takeAWord8 <* element '.' i3 <- takeAWord8 <* element '.' i4 <- takeAWord8 return $ fromTuple (i1, i2, i3, i4) where takeAWord8 = read . toList <$> takeWhile isAsciiDecimal isAsciiDecimal = flip elem ['0'..'9'] foundation-0.0.23/Foundation/Network/IPv6.hs0000644000000000000000000002041613415353646017024 0ustar0000000000000000-- | -- Module : Foundation.Network.IPv6 -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : experimental -- Portability : portable -- -- IPv6 data type -- {-# LANGUAGE FlexibleInstances #-} module Foundation.Network.IPv6 ( IPv6 , any, loopback , fromString, toString , fromTuple, toTuple -- * parsers , ipv6Parser , ipv6ParserPreferred , ipv6ParserCompressed , ipv6ParserIpv4Embedded ) where import Prelude (fromIntegral, read) import qualified Text.Printf as Base import Data.Char (isHexDigit, isDigit) import Numeric (readHex) import Foundation.Class.Storable import Foundation.Hashing.Hashable import Basement.Numerical.Additive (scale) import Basement.Compat.Base import Data.Proxy import Foundation.Primitive import Basement.Types.OffsetSize import Foundation.Numerical import Foundation.Collection (Element, length, intercalate, replicate, null) import Foundation.Parser import Foundation.String (String) import Foundation.Bits -- | IPv6 data type data IPv6 = IPv6 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Eq, Ord, Typeable) instance NormalForm IPv6 where toNormalForm !_ = () instance Hashable IPv6 where hashMix (IPv6 w1 w2) = hashMix w1 . hashMix w2 instance Show IPv6 where show = toLString instance IsString IPv6 where fromString = fromLString instance Storable IPv6 where peek ptr = fromTuple <$> ( (,,,,,,,) <$> (fromBE <$> peekOff ptr' 0) <*> (fromBE <$> peekOff ptr' 1) <*> (fromBE <$> peekOff ptr' 2) <*> (fromBE <$> peekOff ptr' 3) <*> (fromBE <$> peekOff ptr' 4) <*> (fromBE <$> peekOff ptr' 5) <*> (fromBE <$> peekOff ptr' 6) <*> (fromBE <$> peekOff ptr' 7) ) where ptr' :: Ptr (BE Word16) ptr' = castPtr ptr poke ptr ipv6 = do let (i1,i2,i3,i4,i5,i6,i7,i8) = toTuple ipv6 in pokeOff ptr' 0 (toBE i1) >> pokeOff ptr' 1 (toBE i2) >> pokeOff ptr' 2 (toBE i3) >> pokeOff ptr' 3 (toBE i4) >> pokeOff ptr' 4 (toBE i5) >> pokeOff ptr' 5 (toBE i6) >> pokeOff ptr' 6 (toBE i7) >> pokeOff ptr' 7 (toBE i8) where ptr' :: Ptr (BE Word16) ptr' = castPtr ptr instance StorableFixed IPv6 where size _ = (size (Proxy :: Proxy Word64)) `scale` 2 alignment _ = alignment (Proxy :: Proxy Word64) -- | 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 -- -- >>> toString (fromString "0:0:0:0:0:0:0:1" :: IPv6) toString :: IPv6 -> String toString = fromList . toLString toLString :: IPv6 -> [Char] toLString ipv4 = let (i1,i2,i3,i4,i5,i6,i7,i8) = toTuple ipv4 in intercalate ":" $ showHex4 <$> [i1,i2,i3,i4,i5,i6,i7,i8] showHex4 :: Word16 -> [Char] showHex4 = showHex showHex :: Word16 -> [Char] showHex = Base.printf "%04x" fromLString :: [Char] -> IPv6 fromLString = either throw id . parseOnly ipv6Parser -- | create an IPv6 from the given tuple fromTuple :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> IPv6 fromTuple (i1, i2, i3, i4, i5, i6, i7, i8) = IPv6 hi low where f :: Word16 -> Word64 f = fromIntegral hi, low :: Word64 hi = (f i1 .<<. 48) .|. (f i2 .<<. 32) .|. (f i3 .<<. 16) .|. (f i4 ) low = (f i5 .<<. 48) .|. (f i6 .<<. 32) .|. (f i7 .<<. 16) .|. (f i8 ) -- | decompose an IPv6 into a tuple toTuple :: IPv6 -> (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16) toTuple (IPv6 hi low) = (f w1, f w2, f w3, f w4, f w5, f w6, f w7, f w8) where f :: Word64 -> Word16 f = fromIntegral w1, w2, w3, w4, w5, w6, w7, w8 :: Word64 w1 = hi .>>. 48 w2 = hi .>>. 32 w3 = hi .>>. 16 w4 = hi w5 = low .>>. 48 w6 = low .>>. 32 w7 = low .>>. 16 w8 = low -- | IPv6 Parser as described in RFC4291 -- -- for more details: https://tools.ietf.org/html/rfc4291.html#section-2.2 -- -- which is exactly: -- -- ``` -- ipv6ParserPreferred -- <|> ipv6ParserIPv4Embedded -- <|> ipv6ParserCompressed -- ``` -- ipv6Parser :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input IPv6 ipv6Parser = ipv6ParserPreferred <|> ipv6ParserIpv4Embedded <|> ipv6ParserCompressed -- | IPv6 parser as described in RFC4291 section 2.2.1 -- -- The preferred form is x:x:x:x:x:x:x:x, where the 'x's are one to -- four hexadecimal digits of the eight 16-bit pieces of the address. -- -- * `ABCD:EF01:2345:6789:ABCD:EF01:2345:6789` -- * `2001:DB8:0:0:8:800:200C:417A` -- ipv6ParserPreferred :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input IPv6 ipv6ParserPreferred = do i1 <- takeAWord16 <* skipColon i2 <- takeAWord16 <* skipColon i3 <- takeAWord16 <* skipColon i4 <- takeAWord16 <* skipColon i5 <- takeAWord16 <* skipColon i6 <- takeAWord16 <* skipColon i7 <- takeAWord16 <* skipColon i8 <- takeAWord16 return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8) -- | IPv6 address with embedded IPv4 address -- -- when dealing with a mixed environment of IPv4 and IPv6 nodes is -- x:x:x:x:x:x:d.d.d.d, where the 'x's are the hexadecimal values of -- the six high-order 16-bit pieces of the address, and the 'd's are -- the decimal values of the four low-order 8-bit pieces of the -- address (standard IPv4 representation). -- -- * `0:0:0:0:0:0:13.1.68.3` -- * `0:0:0:0:0:FFFF:129.144.52.38` -- * `::13.1.68.3` -- * `::FFFF:129.144.52.38` -- ipv6ParserIpv4Embedded :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input IPv6 ipv6ParserIpv4Embedded = do bs1 <- repeat (Between $ 0 `And` 6 ) $ takeAWord16 <* skipColon _ <- optional skipColon _ <- optional skipColon let (CountOf lenBs1) = length bs1 bs2 <- repeat (Between $ 0 `And` (fromIntegral $ 6 - lenBs1)) $ takeAWord16 <* skipColon _ <- optional skipColon [i1,i2,i3,i4,i5,i6] <- format 6 bs1 bs2 m1 <- takeAWord8 <* skipDot m2 <- takeAWord8 <* skipDot m3 <- takeAWord8 <* skipDot m4 <- takeAWord8 return $ fromTuple ( i1,i2,i3,i4,i5,i6 , m1 `shiftL` 8 .|. m2 , m3 `shiftL` 8 .|. m4 ) -- | IPv6 parser as described in RFC4291 section 2.2.2 -- -- The use of "::" indicates one or more groups of 16 bits of zeros. -- The "::" can only appear once in an address. The "::" can also be -- used to compress leading or trailing zeros in an address. -- -- * `2001:DB8::8:800:200C:417A` -- * `FF01::101` -- * `::1` -- * `::` -- ipv6ParserCompressed :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input IPv6 ipv6ParserCompressed = do bs1 <- repeat (Between $ 0 `And` 8) $ takeAWord16 <* skipColon when (null bs1) skipColon let (CountOf bs1Len) = length bs1 bs2 <- repeat (Between $ 0 `And` fromIntegral (8 - bs1Len)) $ skipColon *> takeAWord16 [i1,i2,i3,i4,i5,i6,i7,i8] <- format 8 bs1 bs2 return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8) format :: (Integral a, Monad m) => CountOf a -> [a] -> [a] -> m [a] format sz bs1 bs2 | sz <= (length bs1 + length bs2) = fail "invalid compressed IPv6 addressed" | otherwise = do let len = sz `sizeSub` (length bs1 + length bs2) return $ bs1 <> replicate len 0 <> bs2 skipColon :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input () skipColon = element ':' skipDot :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input () skipDot = element '.' takeAWord8 :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input Word16 takeAWord8 = read <$> repeat (Between $ 1 `And` 4) (satisfy_ isDigit) takeAWord16 :: (ParserSource input, Element input ~ Char, Element (Chunk input) ~ Char) => Parser input Word16 takeAWord16 = do l <- repeat (Between $ 1 `And` 4) (satisfy_ isHexDigit) let lhs = readHex l in case lhs of [(w, [])] -> return w _ -> fail "can't fall here" foundation-0.0.23/Foundation/System/Info.hs0000644000000000000000000000472113415353646016767 0ustar0000000000000000-- | -- Module : Foundation.System.Info -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE CPP #-} module Foundation.System.Info ( -- * Operation System info OS(..) , os -- * CPU info , Arch(..) , arch , cpus , Endianness(..) , endianness -- * Compiler info , compilerName , System.Info.compilerVersion , Data.Version.Version(..) ) where import qualified System.Info import qualified Data.Version import Data.Data import qualified GHC.Conc import Basement.Compat.Base import Basement.Endianness (Endianness(..), endianness) import Foundation.String data OS = Windows | OSX | Linux | Android | BSD deriving (Show, Eq, Ord, Enum, Bounded, Data, Typeable) -- | get the operating system on which the program is running. -- -- Either return the known `OS` or a strict `String` of the OS name. -- -- This function uses the `base`'s `System.Info.os` function. -- os :: Either [Char] OS os = case System.Info.os of "darwin" -> Right OSX "mingw32" -> Right Windows "linux" -> Right Linux "linux-android" -> Right Android "openbsd" -> Right BSD "netbsd" -> Right BSD "freebsd" -> Right BSD str -> Left str -- | Enumeration of the known GHC supported architecture. -- data Arch = I386 | X86_64 | PowerPC | PowerPC64 | Sparc | Sparc64 | ARM | ARM64 deriving (Show, Eq, Ord, Enum, Bounded, Data, Typeable) -- | get the machine architecture on which the program is running -- -- Either return the known architecture or a Strict `String` of the -- architecture name. -- -- This function uses the `base`'s `System.Info.arch` function. -- arch :: Either [Char] Arch arch = case System.Info.arch of "i386" -> Right I386 "x86_64" -> Right X86_64 "powerpc" -> Right PowerPC "powerpc64" -> Right PowerPC64 "powerpc64le" -> Right PowerPC64 "sparc" -> Right Sparc "sparc64" -> Right Sparc64 "arm" -> Right ARM "aarch64" -> Right ARM64 str -> Left str -- | get the compiler name -- -- get the compilerName from base package but convert -- it into a strict String compilerName :: String compilerName = fromList System.Info.compilerName -- | returns the number of CPUs the machine has cpus :: IO Int cpus = GHC.Conc.getNumProcessors foundation-0.0.23/Foundation/Strict.hs0000644000000000000000000000151313415353646016054 0ustar0000000000000000-- | -- Module : Foundation.Strict -- License : BSD-style -- Maintainer : Foundation -- Stability : stable -- Portability : portable -- -- Enforce strictness when executing lambda -- module Foundation.Strict ( strict1 , strict2 , strict3 , strict4 , strict5 , strict6 ) where strict1 :: (a -> b) -> a -> b strict1 f !a = f a strict2 :: (a -> b -> c) -> a -> b -> c strict2 f !a !b = f a b strict3 :: (a -> b -> c -> d) -> a -> b -> c -> d strict3 f !a !b !c = f a b c strict4 :: (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e strict4 f !a !b !c !d = f a b c d strict5 :: (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f strict5 f !a !b !c !d !e = f a b c d e strict6 :: (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g strict6 f !a !b !c !d !e !g = f a b c d e g foundation-0.0.23/Foundation/Parser.hs0000644000000000000000000004545413415353646016054 0ustar0000000000000000-- | -- Module : Foundation.Parser -- License : BSD-style -- Maintainer : Haskell Foundation -- Stability : experimental -- Portability : portable -- -- The current implementation is mainly, if not copy/pasted, inspired from -- `memory`'s Parser. -- -- Foundation Parser makes use of the Foundation's @Collection@ and -- @Sequential@ classes to allow you to define generic parsers over any -- @Sequential@ of inpu. -- -- This way you can easily implements parsers over @LString@, @String@. -- -- -- > flip parseOnly "my.email@address.com" $ do -- > EmailAddress -- > <$> (takeWhile ((/=) '@' <* element '@') -- > <*> takeAll -- {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Parser ( Parser , parse , parseFeed , parseOnly , -- * Result Result(..) , ParseError(..) , reportError , -- * Parser source ParserSource(..) , -- * combinator peek , element , anyElement , elements , string , satisfy , satisfy_ , take , takeWhile , takeAll , skip , skipWhile , skipAll , (<|>) , many , some , optional , repeat, Condition(..), And(..) ) where import Control.Applicative (Alternative, empty, (<|>), many, some, optional) import Control.Monad (MonadPlus, mzero, mplus) import Basement.Compat.Base import Basement.Types.OffsetSize import Foundation.Numerical import Foundation.Collection hiding (take, takeWhile) import qualified Foundation.Collection as C import Foundation.String -- Error handling ------------------------------------------------------------- -- | common parser error definition data ParseError input = NotEnough (CountOf (Element input)) -- ^ meaning the parser was short of @CountOf@ @Element@ of `input`. | NotEnoughParseOnly -- ^ The parser needed more data, only when using @parseOnly@ | ExpectedElement (Element input) (Element input) -- ^ when using @element@ | Expected (Chunk input) (Chunk input) -- ^ when using @elements@ or @string@ | Satisfy (Maybe String) -- ^ the @satisfy@ or @satisfy_@ function failed, deriving (Typeable) instance (Typeable input, Show input) => Exception (ParseError input) instance Show input => Show (ParseError input) where show (NotEnough (CountOf sz)) = "NotEnough: missing " <> show sz <> " element(s)" show NotEnoughParseOnly = "NotEnough, parse only" show (ExpectedElement _ _) = "Expected _ but received _" show (Expected _ _) = "Expected _ but received _" show (Satisfy Nothing) = "Satisfy" show (Satisfy (Just s)) = "Satisfy: " <> toList s instance {-# OVERLAPPING #-} Show (ParseError String) where show (NotEnough (CountOf sz)) = "NotEnough: missing " <> show sz <> " element(s)" show NotEnoughParseOnly = "NotEnough, parse only" show (ExpectedElement a b) = "Expected "<>show a<>" but received " <> show b show (Expected a b) = "Expected "<>show a<>" but received " <> show b show (Satisfy Nothing) = "Satisfy" show (Satisfy (Just s)) = "Satisfy: " <> toList s -- Results -------------------------------------------------------------------- -- | result of executing the `parser` over the given `input` data Result input result = ParseFailed (ParseError input) -- ^ the parser failed with the given @ParserError@ | ParseOk (Chunk input) result -- ^ the parser complete successfuly with the remaining @Chunk@ | ParseMore (Chunk input -> Result input result) -- ^ the parser needs more input, pass an empty @Chunk@ or @mempty@ -- to tell the parser you don't have anymore inputs. instance (Show k, Show input) => Show (Result input k) where show (ParseFailed err) = "Parser failed: " <> show err show (ParseOk _ k) = "Parser succeed: " <> show k show (ParseMore _) = "Parser incomplete: need more" instance Functor (Result input) where fmap f r = case r of ParseFailed err -> ParseFailed err ParseOk rest a -> ParseOk rest (f a) ParseMore more -> ParseMore (fmap f . more) -- Parser Source -------------------------------------------------------------- class (Sequential input, IndexedCollection input) => ParserSource input where type Chunk input nullChunk :: input -> Chunk input -> Bool appendChunk :: input -> Chunk input -> input subChunk :: input -> Offset (Element input) -> CountOf (Element input) -> Chunk input spanChunk :: input -> Offset (Element input) -> (Element input -> Bool) -> (Chunk input, Offset (Element input)) endOfParserSource :: ParserSource input => input -> Offset (Element input) -> Bool endOfParserSource l off = off .==# length l {-# INLINE endOfParserSource #-} -- Parser --------------------------------------------------------------------- data NoMore = More | NoMore deriving (Show, Eq) type Failure input result = input -> Offset (Element input) -> NoMore -> ParseError input -> Result input result type Success input result' result = input -> Offset (Element input) -> NoMore -> result' -> Result input result -- | Foundation's @Parser@ monad. -- -- Its implementation is based on the parser in `memory`. newtype Parser input result = Parser { runParser :: forall result' . input -> Offset (Element input) -> NoMore -> Failure input result' -> Success input result result' -> Result input result' } instance Functor (Parser input) where fmap f fa = Parser $ \buf off nm err ok -> runParser fa buf off nm err $ \buf' off' nm' a -> ok buf' off' nm' (f a) {-# INLINE fmap #-} instance ParserSource input => Applicative (Parser input) where pure a = Parser $ \buf off nm _ ok -> ok buf off nm a {-# INLINE pure #-} fab <*> fa = Parser $ \buf0 off0 nm0 err ok -> runParser fab buf0 off0 nm0 err $ \buf1 off1 nm1 ab -> runParser_ fa buf1 off1 nm1 err $ \buf2 off2 nm2 -> ok buf2 off2 nm2 . ab {-# INLINE (<*>) #-} instance ParserSource input => Monad (Parser input) where return = pure {-# INLINE return #-} m >>= k = Parser $ \buf off nm err ok -> runParser m buf off nm err $ \buf' off' nm' a -> runParser_ (k a) buf' off' nm' err ok {-# INLINE (>>=) #-} instance ParserSource input => MonadPlus (Parser input) where mzero = error "Foundation.Parser.Internal.MonadPlus.mzero" mplus f g = Parser $ \buf off nm err ok -> runParser f buf off nm (\buf' _ nm' _ -> runParser g buf' off nm' err ok) ok {-# INLINE mplus #-} instance ParserSource input => Alternative (Parser input) where empty = error "Foundation.Parser.Internal.Alternative.empty" (<|>) = mplus {-# INLINE (<|>) #-} runParser_ :: ParserSource input => Parser input result -> input -> Offset (Element input) -> NoMore -> Failure input result' -> Success input result result' -> Result input result' runParser_ parser buf off NoMore err ok = runParser parser buf off NoMore err ok runParser_ parser buf off nm err ok | endOfParserSource buf off = ParseMore $ \chunk -> if nullChunk buf chunk then runParser parser buf off NoMore err ok else runParser parser (appendChunk buf chunk) off nm err ok | otherwise = runParser parser buf off nm err ok {-# INLINE runParser_ #-} -- | Run a parser on an @initial input. -- -- If the Parser need more data than available, the @feeder function -- is automatically called and fed to the More continuation. parseFeed :: (ParserSource input, Monad m) => m (Chunk input) -> Parser input a -> input -> m (Result input a) parseFeed feeder p initial = loop $ parse p initial where loop (ParseMore k) = feeder >>= (loop . k) loop r = return r -- | Run a Parser on a ByteString and return a 'Result' parse :: ParserSource input => Parser input a -> input -> Result input a parse p s = runParser p s 0 More failure success failure :: input -> Offset (Element input) -> NoMore -> ParseError input -> Result input r failure _ _ _ = ParseFailed {-# INLINE failure #-} success :: ParserSource input => input -> Offset (Element input) -> NoMore -> r -> Result input r success buf off _ = ParseOk rest where !rest = subChunk buf off (length buf `sizeSub` offsetAsSize off) {-# INLINE success #-} -- | parse only the given input -- -- The left-over `Element input` will be ignored, if the parser call for more -- data it will be continuously fed with `Nothing` (up to 256 iterations). -- parseOnly :: (ParserSource input, Monoid (Chunk input)) => Parser input a -> input -> Either (ParseError input) a parseOnly p i = case runParser p i 0 NoMore failure success of ParseFailed err -> Left err ParseOk _ r -> Right r ParseMore _ -> Left NotEnoughParseOnly -- ------------------------------------------------------------------------- -- -- String Parser -- -- ------------------------------------------------------------------------- -- instance ParserSource String where type Chunk String = String nullChunk _ = null {-# INLINE nullChunk #-} appendChunk = mappend {-# INLINE appendChunk #-} subChunk c off sz = C.take sz $ C.drop (offsetAsSize off) c {-# INLINE subChunk #-} spanChunk buf off predicate = let c = C.drop (offsetAsSize off) buf (t, _) = C.span predicate c in (t, off `offsetPlusE` length t) {-# INLINE spanChunk #-} instance ParserSource [a] where type Chunk [a] = [a] nullChunk _ = null {-# INLINE nullChunk #-} appendChunk = mappend {-# INLINE appendChunk #-} subChunk c off sz = C.take sz $ C.drop (offsetAsSize off) c {-# INLINE subChunk #-} spanChunk buf off predicate = let c = C.drop (offsetAsSize off) buf (t, _) = C.span predicate c in (t, off `offsetPlusE` length t) {-# INLINE spanChunk #-} -- ------------------------------------------------------------------------- -- -- Helpers -- -- ------------------------------------------------------------------------- -- -- | helper function to report error when writing parsers -- -- This way we can provide more detailed error when building custom -- parsers and still avoid to use the naughty _fail_. -- -- @ -- myParser :: Parser input Int -- myParser = reportError $ Satisfy (Just "this function is not implemented...") -- @ -- reportError :: ParseError input -> Parser input a reportError pe = Parser $ \buf off nm err _ -> err buf off nm pe -- | Get the next `Element input` from the parser anyElement :: ParserSource input => Parser input (Element input) anyElement = Parser $ \buf off nm err ok -> case buf ! off of Nothing -> err buf off nm $ NotEnough 1 Just x -> ok buf (succ off) nm x {-# INLINE anyElement #-} -- | peek the first element from the input source without consuming it -- -- Returns 'Nothing' if there is no more input to parse. -- peek :: ParserSource input => Parser input (Maybe (Element input)) peek = Parser $ \buf off nm err ok -> case buf ! off of Nothing -> runParser_ peekOnly buf off nm err ok Just x -> ok buf off nm (Just x) where peekOnly = Parser $ \buf off nm _ ok -> ok buf off nm (buf ! off) element :: ( ParserSource input , Eq (Element input) , Element input ~ Element (Chunk input) ) => Element input -> Parser input () element expectedElement = Parser $ \buf off nm err ok -> case buf ! off of Nothing -> err buf off nm $ NotEnough 1 Just x | expectedElement == x -> ok buf (succ off) nm () | otherwise -> err buf off nm $ ExpectedElement expectedElement x {-# INLINE element #-} elements :: ( ParserSource input, Sequential (Chunk input) , Element (Chunk input) ~ Element input , Eq (Chunk input) ) => Chunk input -> Parser input () elements = consumeEq where consumeEq :: ( ParserSource input , Sequential (Chunk input) , Element (Chunk input) ~ Element input , Eq (Chunk input) ) => Chunk input -> Parser input () consumeEq expected = Parser $ \buf off nm err ok -> if endOfParserSource buf off then err buf off nm $ NotEnough lenE else let !lenI = sizeAsOffset (length buf) - off in if lenI >= lenE then let a = subChunk buf off lenE in if a == expected then ok buf (off + sizeAsOffset lenE) nm () else err buf off nm $ Expected expected a else let a = subChunk buf off lenI (e', r) = splitAt lenI expected in if a == e' then runParser_ (consumeEq r) buf (off + sizeAsOffset lenI) nm err ok else err buf off nm $ Expected e' a where !lenE = length expected {-# NOINLINE consumeEq #-} {-# INLINE elements #-} -- | take one element if satisfy the given predicate satisfy :: ParserSource input => Maybe String -> (Element input -> Bool) -> Parser input (Element input) satisfy desc predicate = Parser $ \buf off nm err ok -> case buf ! off of Nothing -> err buf off nm $ NotEnough 1 Just x | predicate x -> ok buf (succ off) nm x | otherwise -> err buf off nm $ Satisfy desc {-# INLINE satisfy #-} -- | take one element if satisfy the given predicate satisfy_ :: ParserSource input => (Element input -> Bool) -> Parser input (Element input) satisfy_ = satisfy Nothing {-# INLINE satisfy_ #-} take :: ( ParserSource input , Sequential (Chunk input) , Element input ~ Element (Chunk input) ) => CountOf (Element (Chunk input)) -> Parser input (Chunk input) take n = Parser $ \buf off nm err ok -> let lenI = sizeAsOffset (length buf) - off in if endOfParserSource buf off && n > 0 then err buf off nm $ NotEnough n else case n - lenI of Just s | s > 0 -> let h = subChunk buf off lenI in runParser_ (take s) buf (sizeAsOffset lenI) nm err $ \buf' off' nm' t -> ok buf' off' nm' (h <> t) _ -> ok buf (off + sizeAsOffset n) nm (subChunk buf off n) takeWhile :: ( ParserSource input, Sequential (Chunk input) ) => (Element input -> Bool) -> Parser input (Chunk input) takeWhile predicate = Parser $ \buf off nm err ok -> if endOfParserSource buf off then ok buf off nm mempty else let (b1, off') = spanChunk buf off predicate in if endOfParserSource buf off' then runParser_ (takeWhile predicate) buf off' nm err $ \buf' off'' nm' b1T -> ok buf' off'' nm' (b1 <> b1T) else ok buf off' nm b1 -- | Take the remaining elements from the current position in the stream takeAll :: (ParserSource input, Sequential (Chunk input)) => Parser input (Chunk input) takeAll = getAll >> returnBuffer where returnBuffer :: ParserSource input => Parser input (Chunk input) returnBuffer = Parser $ \buf off nm _ ok -> let !lenI = length buf !off' = sizeAsOffset lenI !sz = off' - off in ok buf off' nm (subChunk buf off sz) {-# INLINE returnBuffer #-} getAll :: (ParserSource input, Sequential (Chunk input)) => Parser input () getAll = Parser $ \buf off nm err ok -> case nm of NoMore -> ok buf off nm () More -> ParseMore $ \nextChunk -> if nullChunk buf nextChunk then ok buf off NoMore () else runParser getAll (appendChunk buf nextChunk) off nm err ok {-# NOINLINE getAll #-} {-# INLINE takeAll #-} skip :: ParserSource input => CountOf (Element input) -> Parser input () skip n = Parser $ \buf off nm err ok -> let lenI = sizeAsOffset (length buf) - off in if endOfParserSource buf off && n > 0 then err buf off nm $ NotEnough n else case n - lenI of Just s | s > 0 -> runParser_ (skip s) buf (sizeAsOffset lenI) nm err ok _ -> ok buf (off + sizeAsOffset n) nm () skipWhile :: ( ParserSource input, Sequential (Chunk input) ) => (Element input -> Bool) -> Parser input () skipWhile predicate = Parser $ \buf off nm err ok -> if endOfParserSource buf off then ok buf off nm () else let (_, off') = spanChunk buf off predicate in if endOfParserSource buf off' then runParser_ (skipWhile predicate) buf off' nm err ok else ok buf off' nm () -- | consume every chunk of the stream -- skipAll :: (ParserSource input, Collection (Chunk input)) => Parser input () skipAll = flushAll where flushAll :: (ParserSource input, Collection (Chunk input)) => Parser input () flushAll = Parser $ \buf off nm err ok -> let !off' = sizeAsOffset $ length buf in case nm of NoMore -> ok buf off' NoMore () More -> ParseMore $ \nextChunk -> if null nextChunk then ok buf off' NoMore () else runParser flushAll buf off nm err ok {-# NOINLINE flushAll #-} {-# INLINE skipAll #-} string :: String -> Parser String () string = elements {-# INLINE string #-} data Condition = Between !And | Exactly !Word deriving (Show, Eq, Typeable) data And = And !Word !Word deriving (Eq, Typeable) instance Show And where show (And a b) = show a <> " and " <> show b -- | repeat the given parser a given amount of time -- -- Unlike @some@ or @many@, this operation will bring more precision on how -- many times you wish a parser to be sequenced. -- -- ## Repeat @Exactly@ a number of time -- -- > repeat (Exactly 6) (takeWhile ((/=) ',') <* element ',') -- -- ## Repeat @Between@ lower `@And@` upper times -- -- > repeat (Between $ 1 `And` 10) (takeWhile ((/=) ',') <* element ',') -- repeat :: ParserSource input => Condition -> Parser input a -> Parser input [a] repeat (Exactly n) = repeatE n repeat (Between a) = repeatA a repeatE :: (ParserSource input) => Word -> Parser input a -> Parser input [a] repeatE 0 _ = return [] repeatE n p = (:) <$> p <*> repeatE (n-1) p repeatA :: (ParserSource input) => And -> Parser input a -> Parser input [a] repeatA (And 0 0) _ = return [] repeatA (And 0 n) p = ((:) <$> p <*> repeatA (And 0 (n-1)) p) <|> return [] repeatA (And l u) p = (:) <$> p <*> repeatA (And (l-1) (u-1)) p foundation-0.0.23/Foundation/Random.hs0000644000000000000000000000233313415353646016025 0ustar0000000000000000-- | -- Module : Foundation.Random -- License : BSD-style -- Stability : experimental -- Portability : Good -- -- This module deals with the random subsystem abstractions. -- -- It provide 2 different set of abstractions: -- -- * The first abstraction that allow a monad to generate random -- through the 'MonadRandom' class. -- -- * The second abstraction to make generic random generator 'RandomGen' -- and a small State monad like wrapper 'MonadRandomState' to -- abstract a generator. -- {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} module Foundation.Random ( MonadRandom(..) , RandomGen(..) , MonadRandomState(..) , withRandomGenerator , RNG , RNGv1 ) where import Foundation.Random.Class import Foundation.Random.DRG import qualified Foundation.Random.ChaChaDRG as ChaChaDRG -- | An alias to the default choice of deterministic random number generator -- -- Unless, you want to have the stability of a specific random number generator, -- e.g. for tests purpose, it's recommended to use this alias so that you would -- keep up to date with possible bugfixes, or change of algorithms. type RNG = RNGv1 type RNGv1 = ChaChaDRG.State foundation-0.0.23/Foundation/Check.hs0000644000000000000000000000606013415353646015623 0ustar0000000000000000-- | -- Module : Foundation.Check -- License : BSD-style -- Maintainer : Foundation maintainers -- -- An implementation of a test framework -- and property expression & testing -- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} module Foundation.Check ( Gen , Arbitrary(..) , oneof , elements , frequency , between -- test , Test(..) , testName -- * Property , PropertyCheck , Property(..) , IsProperty(..) , (===) , propertyCompare , propertyCompareWith , propertyAnd , propertyFail , forAll -- * Check Plan , Check , validate , pick , iterateProperty ) where import Basement.Imports import Basement.Cast (cast) import Basement.IntegralConv import Basement.Types.OffsetSize import Foundation.Check.Gen import Foundation.Check.Arbitrary import Foundation.Check.Property import Foundation.Check.Types import Foundation.Check.Print import Foundation.Monad import Foundation.Monad.State import Foundation.Numerical import Control.Exception (evaluate, SomeException) validate :: IsProperty prop => String -> prop -> Check () validate propertyName prop = Check $ do (genrng, params) <- withState $ \st -> ( (planRng st, planParams st) , st { planValidations = planValidations st + 1 } ) (r,nb) <- liftIO $ iterateProperty 100 params genrng (property prop) case r of PropertySuccess -> return () PropertyFailed failMsg -> do withState $ \st -> ((), st { planFailures = PropertyResult propertyName nb (PropertyFailed failMsg) : planFailures st }) return () pick :: String -> IO a -> Check a pick _ io = Check $ do -- TODO catch most exception to report failures r <- liftIO io pure r iterateProperty :: CountOf TestResult -> GenParams -> (Word64 -> GenRng) -> Property -> IO (PropertyResult, CountOf TestResult) iterateProperty limit genParams genRngIter prop = iterProp 1 where iterProp !iter | iter == limit = return (PropertySuccess, iter) | otherwise = do r <- liftIO toResult case r of (PropertyFailed e, _) -> return (PropertyFailed e, iter) (PropertySuccess, cont) | cont -> iterProp (iter+1) | otherwise -> return (PropertySuccess, iter) where iterW64 :: Word64 iterW64 = let (CountOf iter') = iter in cast (integralUpsize iter' :: Int64) -- TODO revisit to let through timeout and other exception like ctrl-c or thread killing. toResult :: IO (PropertyResult, Bool) toResult = (propertyToResult <$> evaluate (runGen (unProp prop) (genRngIter iterW64) genParams)) `catch` (\(e :: SomeException) -> return (PropertyFailed (show e), False)) foundation-0.0.23/Foundation/Check/Main.hs0000644000000000000000000002405613415353646016514 0ustar0000000000000000-- | -- Module : Foundation.Check.Main -- License : BSD-style -- Maintainer : Foundation maintainers -- -- An application to check that integrate with the .cabal test-suite -- {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Foundation.Check.Main ( defaultMain ) where import Basement.Imports import Basement.IntegralConv import Basement.Cast (cast) import Basement.Bounded import Basement.Types.OffsetSize import qualified Basement.Terminal.ANSI as ANSI import qualified Basement.Terminal as Terminal import Foundation.Collection import Foundation.Numerical import Foundation.IO.Terminal import Foundation.Check (iterateProperty) import Foundation.Check.Gen import Foundation.Check.Property import Foundation.Check.Config import Foundation.Check.Types import Foundation.List.DList import Foundation.Random import Foundation.Monad import Foundation.Monad.State import Data.Maybe (catMaybes) nbFail :: TestResult -> HasFailures nbFail (PropertyResult _ _ (PropertyFailed _)) = 1 nbFail (PropertyResult _ _ PropertySuccess) = 0 nbFail (GroupResult _ t _ _) = t nbTests :: TestResult -> CountOf TestResult nbTests (PropertyResult _ t _) = t nbTests (GroupResult _ _ t _) = t data TestState = TestState { config :: !Config , getSeed :: !Seed , indent :: !(CountOf Char) , testPassed :: !Word , testFailed :: !Word , testPath :: !(DList String) } newState :: Config -> Seed -> TestState newState cfg initSeed = TestState { testPath = mempty , testPassed = 0 , testFailed = 0 , indent = 0 , getSeed = initSeed , config = cfg } filterTestMatching :: Config -> Test -> Maybe Test filterTestMatching cfg testRoot | null (testNameMatch cfg) = Just testRoot | otherwise = testFilter [] testRoot where match acc s = or (flip isInfixOf currentTestName <$> testNameMatch cfg) where currentTestName = fqTestName (s:acc) testFilter acc x = case x of Group s l -> let filtered = catMaybes $ fmap (testFilter (s:acc)) l in if null filtered then Nothing else Just (Group s filtered) CheckPlan s _ | match acc s -> Just x | otherwise -> Nothing Unit s _ | match acc s -> Just x | otherwise -> Nothing Property s _ | match acc s -> Just x | otherwise -> Nothing -- | Run tests defaultMain :: Test -> IO () defaultMain allTestRoot = do Terminal.initialize -- parse arguments ecfg <- flip parseArgs defaultConfig <$> getArgs cfg <- case ecfg of Left e -> do putStrLn e mapM_ putStrLn configHelp exitFailure Right c -> pure c -- use the user defined seed or generate a new seed seed <- maybe getRandomWord64 pure $ udfSeed cfg let testState = newState cfg seed when (helpRequested cfg) (mapM_ putStrLn configHelp >> exitSuccess) when (listTests cfg) (printTestName >> exitSuccess) putStrLn $ "\nSeed: " <> show seed <> "\n" case filterTestMatching cfg allTestRoot of Nothing -> putStrLn "no tests to run" >> exitSuccess Just t -> do (_, cfg') <- runStateT (runCheckMain $ test t) testState summary cfg' where -- display a summary of the result and use the right exit code summary cfg | kos > 0 = do putStrLn $ red <> "Failed " <> show kos <> " out of " <> show tot <> reset exitFailure | otherwise = do putStrLn $ green <> "Succeed " <> show oks <> " test(s)" <> reset exitSuccess where oks = testPassed cfg kos = testFailed cfg tot = oks + kos -- print all the tests recursively printTestName = mapM_ (\tst -> putStrLn (fqTestName tst)) $ testCases [] [] [] allTestRoot where testCases acc xs pre x = case x of Group s l -> tToList (fmap (\z -> (z, pre)) xs <> acc) (s:pre) l CheckPlan s _ -> (s : pre) : tToList acc pre xs Unit s _ -> (s : pre) : tToList acc pre xs Property s _ -> (s : pre) : tToList acc pre xs tToList [] _ [] = [] tToList ((a,pre):as) _ [] = testCases as [] pre a tToList acc pre (x:xs) = testCases acc xs pre x -- | internal check monad for facilitating the tests traversal newtype CheckMain a = CheckMain { runCheckMain :: StateT TestState IO a } deriving (Functor, Applicative, Monad, MonadIO) instance MonadState CheckMain where type State CheckMain = TestState withState = CheckMain . withState onDisplayOption :: DisplayOption -> CheckMain () -> CheckMain () onDisplayOption opt chk = do on <- (<=) opt . displayOptions . config <$> get if on then chk else return () whenErrorOnly :: CheckMain () -> CheckMain () whenErrorOnly = onDisplayOption DisplayTerminalErrorOnly whenGroupOnly :: CheckMain () -> CheckMain () whenGroupOnly = onDisplayOption DisplayGroupOnly whenVerbose :: CheckMain () -> CheckMain () whenVerbose = onDisplayOption DisplayTerminalVerbose passed :: CheckMain () passed = withState $ \s -> ((), s { testPassed = testPassed s + 1 }) failed :: CheckMain () failed = withState $ \s -> ((), s { testFailed = testFailed s + 1 }) test :: Test -> CheckMain TestResult test (Group s l) = pushGroup s l test (Unit _ _) = undefined test (CheckPlan name plan) = do testCheckPlan name plan test (Property name prop) = do r'@(PropertyResult _ nb r) <- testProperty name (property prop) case r of PropertySuccess -> whenVerbose $ displayPropertySucceed name nb PropertyFailed w -> whenErrorOnly $ displayPropertyFailed name nb w return r' displayCurrent :: String -> CheckMain () displayCurrent name = do i <- indent <$> get liftIO $ putStrLn $ replicate i ' ' <> name displayPropertySucceed :: String -> CountOf TestResult -> CheckMain () displayPropertySucceed name (CountOf nb) = do i <- indent <$> get liftIO $ putStrLn $ mconcat [ replicate i ' ' , successString, name , " (" , show nb , if nb == 1 then " test)" else " tests)" ] unicodeEnabled :: Bool unicodeEnabled = True successString :: String successString | unicodeEnabled = green <> " ✓ " <> reset | otherwise = green <> "[SUCCESS] " <> reset {-# NOINLINE successString #-} failureString :: String failureString | unicodeEnabled = red <> " ✗ " <> reset | otherwise = red <> "[ ERROR ] " <> reset {-# NOINLINE failureString #-} reset, green, red :: ANSI.Escape reset = ANSI.sgrReset green = ANSI.sgrForeground (zn64 2) True red = ANSI.sgrForeground (zn64 1) True displayPropertyFailed :: String -> CountOf TestResult -> String -> CheckMain () displayPropertyFailed name (CountOf nb) w = do seed <- getSeed <$> get i <- indent <$> get liftIO $ do putStrLn $ mconcat [ replicate i ' ' , failureString, name , " failed after " , show nb , if nb == 1 then " test" else " tests:" ] putStrLn $ replicate i ' ' <> " use param: --seed " <> show seed putStrLn w pushGroup :: String -> [Test] -> CheckMain TestResult pushGroup name list = do whenGroupOnly $ if groupHasSubGroup list then displayCurrent name else return () withState $ \s -> ((), s { testPath = push (testPath s) name, indent = indent s + 2 }) results <- mapM test list withState $ \s -> ((), s { testPath = pop (testPath s), indent = indent s `sizeSub` 2 }) let totFail = sum $ fmap nbFail results tot = sum $ fmap nbTests results whenGroupOnly $ case (groupHasSubGroup list, totFail) of (True, _) -> return () (False, n) | n > 0 -> displayPropertyFailed name n "" | otherwise -> displayPropertySucceed name tot return $ GroupResult name totFail tot results where sum = foldl' (+) 0 push = snoc pop = maybe mempty fst . unsnoc testCheckPlan :: String -> Check () -> CheckMain TestResult testCheckPlan name actions = do seed <- getSeed <$> get path <- testPath <$> get params <- getGenParams . config <$> get let rngIt = genRng seed (name : toList path) let planState = PlanState { planRng = rngIt , planValidations = 0 , planParams = params , planFailures = [] } st <- liftIO (snd <$> runStateT (runCheck actions) planState) let fails = planFailures st if null fails then return (GroupResult name 0 (planValidations st) []) else do displayCurrent name forM_ fails $ \(PropertyResult name' nb r) -> case r of PropertySuccess -> whenVerbose $ displayPropertySucceed (name <> ": " <> name') nb PropertyFailed w -> whenErrorOnly $ displayPropertyFailed (name <> ": " <> name') nb w return (GroupResult name (length fails) (planValidations st) fails) testProperty :: String -> Property -> CheckMain TestResult testProperty name prop = do seed <- getSeed <$> get path <- testPath <$> get let rngIt = genRng seed (name : toList path) params <- getGenParams . config <$> get maxTests <- numTests . config <$> get (res,nb) <- liftIO $ iterateProperty (CountOf $ integralDownsize (cast maxTests :: Int64)) params rngIt prop case res of PropertyFailed {} -> failed PropertySuccess -> passed return (PropertyResult name nb res) foundation-0.0.23/Foundation/Timing.hs0000644000000000000000000000474713415353646016047 0ustar0000000000000000-- | -- Module : Foundation.Timing -- License : BSD-style -- Maintainer : Foundation maintainers -- -- An implementation of a timing framework -- {-# LANGUAGE CPP #-} module Foundation.Timing ( Timing(..) , Measure(..) , stopWatch , measure ) where import Basement.Imports hiding (from) import Basement.From (from) #if __GLASGOW_HASKELL__ < 802 import Basement.Cast (cast) #endif import Basement.Monad -- import Basement.UArray hiding (unsafeFreeze) import Basement.UArray.Mutable (MUArray) import Foundation.Collection import Foundation.Time.Types import Foundation.Numerical import Foundation.Time.Bindings import Control.Exception (evaluate) import System.Mem (performGC) import Data.Function (on) import qualified GHC.Stats as GHC data Timing = Timing { timeDiff :: !NanoSeconds , timeBytesAllocated :: !(Maybe Word64) } data Measure = Measure { measurements :: UArray NanoSeconds , iters :: Word } #if __GLASGOW_HASKELL__ >= 802 type GCStats = GHC.RTSStats getGCStats :: IO (Maybe GCStats) getGCStats = do r <- GHC.getRTSStatsEnabled if r then pure Nothing else Just <$> GHC.getRTSStats diffGC :: Maybe GHC.RTSStats -> Maybe GHC.RTSStats -> Maybe Word64 diffGC gc2 gc1 = ((-) `on` GHC.allocated_bytes) <$> gc2 <*> gc1 #else type GCStats = GHC.GCStats getGCStats :: IO (Maybe GCStats) getGCStats = do r <- GHC.getGCStatsEnabled if r then pure Nothing else Just <$> GHC.getGCStats diffGC :: Maybe GHC.GCStats -> Maybe GHC.GCStats -> Maybe Word64 diffGC gc2 gc1 = cast <$> (((-) `on` GHC.bytesAllocated) <$> gc2 <*> gc1) #endif -- | Simple one-time measurement of time & other metrics spent in a function stopWatch :: (a -> b) -> a -> IO Timing stopWatch f !a = do performGC gc1 <- getGCStats (_, ns) <- measuringNanoSeconds (evaluate $ f a) gc2 <- getGCStats return $ Timing ns (diffGC gc2 gc1) -- | In depth timing & other metrics analysis of a function measure :: Word -> (a -> b) -> a -> IO Measure measure nbIters f a = do d <- mutNew (from nbIters) :: IO (MUArray NanoSeconds (PrimState IO)) loop d 0 Measure <$> unsafeFreeze d <*> pure nbIters where loop d !i | i == nbIters = return () | otherwise = do (_, r) <- measuringNanoSeconds (evaluate $ f a) mutUnsafeWrite d (from i) r loop d (i+1) foundation-0.0.23/Foundation/Timing/Main.hs0000644000000000000000000000345113415353646016722 0ustar0000000000000000-- | -- Module : Foundation.Timing.Main -- License : BSD-style -- Maintainer : Foundation maintainers -- -- An implementation of a timing framework -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Foundation.Timing.Main ( defaultMain ) where import Basement.Imports import Foundation.IO.Terminal import Foundation.Collection data MainConfig = MainConfig { mainHelp :: Bool , mainListBenchs :: Bool , mainVerbose :: Bool , mainOther :: [String] } newtype TimingPlan a = TimingPlan { runTimingPlan :: IO a } deriving (Functor, Applicative, Monad) defaultMainConfig :: MainConfig defaultMainConfig = MainConfig { mainHelp = False , mainListBenchs = False , mainVerbose = False , mainOther = [] } parseArgs :: [String] -> MainConfig -> Either String MainConfig parseArgs [] cfg = Right cfg parseArgs ("--list-benchs":xs) cfg = parseArgs xs $ cfg { mainListBenchs = True } parseArgs ("--verbose":xs) cfg = parseArgs xs $ cfg { mainVerbose = True } parseArgs ("--help":xs) cfg = parseArgs xs $ cfg { mainHelp = True } parseArgs (x:xs) cfg = parseArgs xs $ cfg { mainOther = x : mainOther cfg } configHelp :: [String] configHelp = [] defaultMain :: TimingPlan () -> IO () defaultMain tp = do ecfg <- flip parseArgs defaultMainConfig <$> getArgs cfg <- case ecfg of Left e -> do putStrLn e mapM_ putStrLn configHelp exitFailure Right c -> pure c when (mainHelp cfg) (mapM_ putStrLn configHelp >> exitSuccess) when (mainListBenchs cfg) (printAll >> exitSuccess) runTimingPlan tp return () where printAll = undefined foundation-0.0.23/Foundation/Time/Types.hs0000644000000000000000000000364113415353646016612 0ustar0000000000000000-- | -- Module : Foundation.Timing -- License : BSD-style -- Maintainer : Foundation maintainers -- -- An implementation of a timing framework -- {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Time.Types ( NanoSeconds(..) , Seconds(..) ) where import Data.Proxy import Basement.Imports import Basement.PrimType import Foundation.Numerical import Data.Coerce -- | An amount of nanoseconds newtype NanoSeconds = NanoSeconds Word64 deriving (Show,Eq,Ord,Additive,Enum,Bounded) instance PrimType NanoSeconds where type PrimSize NanoSeconds = 8 primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64) primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) primMbaURead mba ofs = primMbaURead mba (coerce ofs) primMbaUWrite mba ofs v = primMbaUWrite mba (coerce ofs) (coerce v :: Word64) primAddrIndex addr ofs = primAddrIndex addr (coerce ofs) primAddrRead addr ofs = primAddrRead addr (coerce ofs) primAddrWrite addr ofs v = primAddrWrite addr (coerce ofs) (coerce v :: Word64) -- | An amount of seconds newtype Seconds = Seconds Word64 deriving (Show,Eq,Ord,Additive,Enum,Bounded) instance PrimType Seconds where type PrimSize Seconds = 8 primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64) primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) primMbaURead mba ofs = primMbaURead mba (coerce ofs) primMbaUWrite mba ofs v = primMbaUWrite mba (coerce ofs) (coerce v :: Word64) primAddrIndex addr ofs = primAddrIndex addr (coerce ofs) primAddrRead addr ofs = primAddrRead addr (coerce ofs) primAddrWrite addr ofs v = primAddrWrite addr (coerce ofs) (coerce v :: Word64) foundation-0.0.23/Foundation/Time/Bindings.hs0000644000000000000000000000206613415353646017243 0ustar0000000000000000{-# LANGUAGE CPP #-} module Foundation.Time.Bindings ( measuringNanoSeconds , getMonotonicTime ) where import Basement.Imports import Basement.Types.OffsetSize import Basement.Types.Ptr import Foundation.System.Bindings.Time import Foundation.Time.Types import Foundation.Foreign.Alloc import Foreign.Storable measuringNanoSeconds :: IO a -> IO (a, NanoSeconds) measuringNanoSeconds f = allocaBytes (sizeOfCSize size_CTimeSpec) $ \t1 -> allocaBytes (sizeOfCSize size_CTimeSpec) $ \t2 -> do _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC t1 r <- f _err2 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC t2 return (r, NanoSeconds 0) getMonotonicTime :: IO (Seconds, NanoSeconds) getMonotonicTime = allocaBytes (sizeOfCSize size_CTimeSpec) $ \tspec -> do _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC tspec s <- Seconds <$> peek (castPtr (tspec `ptrPlus` ofs_CTimeSpec_Seconds)) ns <- NanoSeconds <$> peek (castPtr (tspec `ptrPlus` ofs_CTimeSpec_NanoSeconds)) return (s,ns) foundation-0.0.23/Foundation/Time/StopWatch.hs0000644000000000000000000000726213415353646017425 0ustar0000000000000000{-# LANGUAGE CPP #-} module Foundation.Time.StopWatch ( StopWatchPrecise , startPrecise , stopPrecise ) where import Basement.Imports import Basement.Types.Ptr import Foundation.Time.Types import Basement.Block.Mutable import Foundation.Numerical import Foreign.Storable #if defined(mingw32_HOST_OS) import System.Win32.Time import Basement.Monad import Basement.IntegralConv import System.IO.Unsafe #elif defined(darwin_HOST_OS) import Foundation.System.Bindings.Macos import Basement.IntegralConv import System.IO.Unsafe import Basement.Types.OffsetSize #else import Foundation.System.Bindings.Time import Basement.Monad import Basement.Types.OffsetSize #endif -- | A precise stop watch -- -- The precision is higher than a normal stopwatch, but -- also on some system it might not be able to record -- longer period of time accurately (possibly wrapping) newtype StopWatchPrecise = #if defined(darwin_HOST_OS) StopWatchPrecise Word64 #elif defined(mingw32_HOST_OS) -- contain 2 LARGE_INTEGER (int64_t) StopWatchPrecise (MutableBlock Word8 (PrimState IO)) #else -- contains 2 timespec (16 bytes) StopWatchPrecise (MutableBlock Word8 (PrimState IO)) #endif #if defined(mingw32_HOST_OS) initPrecise :: Word64 initPrecise = unsafePerformIO $ integralDownsize <$> queryPerformanceFrequency {-# NOINLINE initPrecise #-} #elif defined(darwin_HOST_OS) initPrecise :: (Word64, Word64) initPrecise = unsafePerformIO $ do mti <- newPinned (sizeOfCSize size_MachTimebaseInfo) withMutablePtr mti $ \p -> do sysMacos_timebase_info (castPtr p) let p32 = castPtr p :: Ptr Word32 !n <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_numer) !d <- peek (p32 `ptrPlus` ofs_MachTimebaseInfo_denom) pure (integralUpsize n, integralUpsize d) {-# NOINLINE initPrecise #-} #endif -- | Create a new precise stop watch -- -- record the time at start of call startPrecise :: IO StopWatchPrecise startPrecise = do #if defined(mingw32_HOST_OS) blk <- newPinned 16 _ <- withMutablePtr blk $ \p -> c_QueryPerformanceCounter (castPtr p `ptrPlus` 8) pure (StopWatchPrecise blk) #elif defined(darwin_HOST_OS) StopWatchPrecise <$> sysMacos_absolute_time #else blk <- newPinned (sizeOfCSize (size_CTimeSpec + size_CTimeSpec)) _err1 <- withMutablePtr blk $ \p -> do sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p `ptrPlusCSz` size_CTimeSpec) pure (StopWatchPrecise blk) #endif -- | Get the number of nano seconds since the call to `startPrecise` stopPrecise :: StopWatchPrecise -> IO NanoSeconds stopPrecise (StopWatchPrecise blk) = do #if defined(mingw32_HOST_OS) withMutablePtr blk $ \p -> do _ <- c_QueryPerformanceCounter (castPtr p) let p64 = castPtr p :: Ptr Word64 end <- peek p64 start <- peek (p64 `ptrPlus` 8) pure $ NanoSeconds ((end - start) * secondInNano `div` initPrecise) #elif defined(darwin_HOST_OS) end <- sysMacos_absolute_time pure $ NanoSeconds $ case initPrecise of (1,1) -> end - blk (numer,denom) -> ((end - blk) * numer) `div` denom #else withMutablePtr blk $ \p -> do _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC (castPtr p) let p64 = castPtr p :: Ptr Word64 endSec <- peek p64 startSec <- peek (p64 `ptrPlusCSz` size_CTimeSpec) endNSec <- peek (p64 `ptrPlus` ofs_CTimeSpec_NanoSeconds) startNSec <- peek (p64 `ptrPlus` (sizeAsOffset (sizeOfCSize size_CTimeSpec) + ofs_CTimeSpec_NanoSeconds)) pure $ NanoSeconds $ (endSec * secondInNano + endNSec) - (startSec * secondInNano + startNSec) #endif #if !defined(darwin_HOST_OS) secondInNano :: Word64 secondInNano = 1000000000 #endif foundation-0.0.23/Foundation/Tuple/Nth.hs0000644000000000000000000000514113415353646016427 0ustar0000000000000000-- | -- Module : Foundation.Tuple.Nat -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- a Generalized version of Fstable, Sndable, .. -- -- Using this module is limited to GHC 7.10 and above. -- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Tuple.Nth (Nthable(..)) where import GHC.TypeLits import Foundation.Tuple -- | A generalized version of indexed accessor allowing -- access to tuples n'th element. -- -- Indexing starts at 1, as 'fst' is used to get first element. class KnownNat n => Nthable n a where type NthTy n a nth :: proxy n -> a -> NthTy n a -------------------- -- 2 elements tuple -------------------- instance Nthable 1 (a,b) where type NthTy 1 (a,b) = a nth _ (a,_) = a instance Nthable 2 (a,b) where type NthTy 2 (a,b) = b nth _ (_,b) = b instance Nthable 1 (Tuple2 a b) where type NthTy 1 (Tuple2 a b) = a nth _ (Tuple2 a _) = a instance Nthable 2 (Tuple2 a b) where type NthTy 2 (Tuple2 a b) = b nth _ (Tuple2 _ b) = b -------------------- -- 3 elements tuple -------------------- instance Nthable 1 (a,b,c) where type NthTy 1 (a,b,c) = a nth _ (a,_,_) = a instance Nthable 2 (a,b,c) where type NthTy 2 (a,b,c) = b nth _ (_,b,_) = b instance Nthable 3 (a,b,c) where type NthTy 3 (a,b,c) = c nth _ (_,_,c) = c instance Nthable 1 (Tuple3 a b c) where type NthTy 1 (Tuple3 a b c) = a nth _ (Tuple3 a _ _) = a instance Nthable 2 (Tuple3 a b c) where type NthTy 2 (Tuple3 a b c) = b nth _ (Tuple3 _ b _) = b instance Nthable 3 (Tuple3 a b c) where type NthTy 3 (Tuple3 a b c) = c nth _ (Tuple3 _ _ c) = c -------------------- -- 4 elements tuple -------------------- instance Nthable 1 (a,b,c,d) where type NthTy 1 (a,b,c,d) = a nth _ (a,_,_,_) = a instance Nthable 2 (a,b,c,d) where type NthTy 2 (a,b,c,d) = b nth _ (_,b,_,_) = b instance Nthable 3 (a,b,c,d) where type NthTy 3 (a,b,c,d) = c nth _ (_,_,c,_) = c instance Nthable 4 (a,b,c,d) where type NthTy 4 (a,b,c,d) = d nth _ (_,_,_,d) = d instance Nthable 1 (Tuple4 a b c d) where type NthTy 1 (Tuple4 a b c d) = a nth _ (Tuple4 a _ _ _) = a instance Nthable 2 (Tuple4 a b c d) where type NthTy 2 (Tuple4 a b c d) = b nth _ (Tuple4 _ b _ _) = b instance Nthable 3 (Tuple4 a b c d) where type NthTy 3 (Tuple4 a b c d) = c nth _ (Tuple4 _ _ c _) = c instance Nthable 4 (Tuple4 a b c d) where type NthTy 4 (Tuple4 a b c d) = d nth _ (Tuple4 _ _ _ d) = d foundation-0.0.23/Foundation/UUID.hs0000644000000000000000000001257713415353646015366 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Foundation.UUID ( UUID(..) , newUUID , nil , fromBinary , uuidParser ) where import Data.Maybe (fromMaybe) import Basement.Compat.Base import Foundation.Collection (Element, Sequential, foldl') import Foundation.Class.Storable import Foundation.Hashing.Hashable import Foundation.Bits import Foundation.Parser import Foundation.Numerical import Foundation.Primitive import Basement.Base16 import Basement.IntegralConv import Basement.Types.OffsetSize import qualified Basement.UArray as UA import Foundation.Random (MonadRandom, getRandomBytes) data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Eq,Ord,Typeable) instance Show UUID where show = toLString instance NormalForm UUID where toNormalForm !_ = () instance Hashable UUID where hashMix (UUID a b) = hashMix a . hashMix b instance Storable UUID where 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 Word32x2 wHigh wLow -> hexWord_2 (integralDownsize wHigh) $ hexWord_4 wLow l nil :: UUID nil = UUID 0 0 newUUID :: MonadRandom randomly => randomly UUID newUUID = fromMaybe (error "Foundation.UUID.newUUID: the impossible happned") . fromBinary <$> getRandomBytes 16 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) uuidParser :: ( ParserSource input, Element input ~ Char , Sequential (Chunk input), Element input ~ Element (Chunk input) ) => Parser input UUID uuidParser = do hex1 <- parseHex (CountOf 8) <* element '-' hex2 <- parseHex (CountOf 4) <* element '-' hex3 <- parseHex (CountOf 4) <* element '-' hex4 <- parseHex (CountOf 4) <* element '-' hex5 <- parseHex (CountOf 12) return $ UUID (hex1 .<<. 32 .|. hex2 .<<. 16 .|. hex3) (hex4 .<<. 48 .|. hex5) parseHex :: ( ParserSource input, Element input ~ Char , Sequential (Chunk input), Element input ~ Element (Chunk input) ) => CountOf Char -> Parser input Word64 parseHex count = do r <- toList <$> take count unless (and $ isValidHexa <$> r) $ reportError $ Satisfy $ Just $ "expecting hexadecimal character only: " <> fromList (show r) return $ listToHex 0 r where listToHex = foldl' (\acc' x -> acc' * 16 + fromHex x) isValidHexa :: Char -> Bool isValidHexa c = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f') || ('A' <= c && c <= 'F') fromHex '0' = 0 fromHex '1' = 1 fromHex '2' = 2 fromHex '3' = 3 fromHex '4' = 4 fromHex '5' = 5 fromHex '6' = 6 fromHex '7' = 7 fromHex '8' = 8 fromHex '9' = 9 fromHex 'a' = 10 fromHex 'b' = 11 fromHex 'c' = 12 fromHex 'd' = 13 fromHex 'e' = 14 fromHex 'f' = 15 fromHex 'A' = 10 fromHex 'B' = 11 fromHex 'C' = 12 fromHex 'D' = 13 fromHex 'E' = 14 fromHex 'F' = 15 fromHex _ = error "Foundation.UUID.parseUUID: the impossible happened" foundation-0.0.23/Foundation/System/Entropy.hs0000644000000000000000000000232513415353646017532 0ustar0000000000000000-- | -- Module : Foundation.System.Entropy -- License : BSD-style -- Maintainer : Foundation -- Stability : stable -- Portability : good -- {-# LANGUAGE CPP #-} module Foundation.System.Entropy ( getEntropy ) where import Basement.Compat.Base import Basement.Types.OffsetSize import qualified Basement.UArray.Mutable as A import qualified Basement.UArray as A import Control.Exception import Foreign.Ptr import Foundation.Numerical import Foundation.System.Entropy.Common #ifdef mingw32_HOST_OS import Foundation.System.Entropy.Windows #else import Foundation.System.Entropy.Unix #endif -- | Get some of the system entropy getEntropy :: CountOf Word8 -> IO (A.UArray Word8) getEntropy n@(CountOf 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 () loop _ 0 _ = return () loop ctx i p = do let chSz = min entropyMaximumSize i r <- entropyGather ctx p chSz if r then loop ctx (i-chSz) (p `plusPtr` chSz) else throwIO EntropySystemMissing foundation-0.0.23/Foundation/System/Bindings.hs0000644000000000000000000000036013415353646017624 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} module Foundation.System.Bindings ( module X ) where #ifdef mingw32_HOST_OS import Foundation.System.Bindings.Windows as X #else import Foundation.System.Bindings.Posix as X #endif foundation-0.0.23/Foundation/Network/HostName.hsc0000644000000000000000000001256013415353646020122 0ustar0000000000000000-- | -- 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 Basement.Compat.Base import Basement.Compat.C.Types import Data.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.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) foundation-0.0.23/Foundation/System/Bindings/Windows.hs0000644000000000000000000000012213415353646021252 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Windows where foundation-0.0.23/Foundation/System/Bindings/Posix.hsc0000644000000000000000000002576013415353646021104 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Foundation.System.Bindings.Posix -- Copyright : (c) Vincent Hanquez 2014-2017 -- License : BSD-style -- -- Maintainer : Vincent Hanquez -- Stability : provisional -- Portability : non-portable (requires POSIX) -- -- Functions defined by the POSIX standards -- ----------------------------------------------------------------------------- {-# LANGUAGE CApiFFI #-} {-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Posix where import Basement.Compat.Base import Basement.Compat.C.Types import Data.Bits import Foundation.System.Bindings.PosixDef #include #include #include #include #include data CDir data CDirent sysPosix_E2BIG , sysPosix_EACCES , sysPosix_EADDRINUSE , sysPosix_EADDRNOTAVAIL , sysPosix_EAFNOSUPPORT , sysPosix_EAGAIN , sysPosix_EALREADY , sysPosix_EBADF , sysPosix_EBUSY , sysPosix_ECANCELED , sysPosix_ECHILD , sysPosix_ECONNABORTED , sysPosix_ECONNREFUSED , sysPosix_ECONNRESET , sysPosix_EDEADLK , sysPosix_EDESTADDRREQ , sysPosix_EDOM , sysPosix_EDQUOT , sysPosix_EEXIST , sysPosix_EFAULT , sysPosix_EFBIG , sysPosix_EHOSTUNREACH , sysPosix_EIDRM , sysPosix_EILSEQ , sysPosix_EINPROGRESS , sysPosix_EINTR , sysPosix_EINVAL , sysPosix_EIO , sysPosix_EISCONN , sysPosix_EISDIR , sysPosix_ELOOP , sysPosix_EMFILE , sysPosix_EMLINK , sysPosix_EMSGSIZE , sysPosix_ENAMETOOLONG , sysPosix_ENETDOWN , sysPosix_ENETRESET , sysPosix_ENETUNREACH , sysPosix_ENFILE , sysPosix_ENOBUFS , sysPosix_ENODEV , sysPosix_ENOENT , sysPosix_ENOEXEC , sysPosix_ENOLCK , sysPosix_ENOMEM , sysPosix_ENOMSG , sysPosix_ENOPROTOOPT , sysPosix_ENOSPC , sysPosix_ENOSYS , sysPosix_ENOTCONN , sysPosix_ENOTDIR , sysPosix_ENOTEMPTY , sysPosix_ENOTSOCK , sysPosix_ENOTSUP , sysPosix_ENOTTY , sysPosix_ENXIO , sysPosix_EOPNOTSUPP , sysPosix_EOVERFLOW , sysPosix_EPERM , sysPosix_EPIPE , sysPosix_EPROTONOSUPPORT , sysPosix_EPROTOTYPE , sysPosix_ERANGE , sysPosix_EROFS , sysPosix_ESPIPE , sysPosix_ESRCH , sysPosix_ESTALE , sysPosix_ETIMEDOUT , sysPosix_ETXTBSY , sysPosix_EWOULDBLOCK , sysPosix_EXDEV :: CErrno sysPosix_E2BIG = (#const E2BIG) sysPosix_EACCES = (#const EACCES) sysPosix_EADDRINUSE = (#const EADDRINUSE) sysPosix_EADDRNOTAVAIL = (#const EADDRNOTAVAIL) sysPosix_EAFNOSUPPORT = (#const EAFNOSUPPORT) sysPosix_EAGAIN = (#const EAGAIN) sysPosix_EALREADY = (#const EALREADY) sysPosix_EBADF = (#const EBADF) sysPosix_EBUSY = (#const EBUSY) sysPosix_ECANCELED = (#const ECANCELED) sysPosix_ECHILD = (#const ECHILD) sysPosix_ECONNABORTED = (#const ECONNABORTED) sysPosix_ECONNREFUSED = (#const ECONNREFUSED) sysPosix_ECONNRESET = (#const ECONNRESET) sysPosix_EDEADLK = (#const EDEADLK) sysPosix_EDESTADDRREQ = (#const EDESTADDRREQ) sysPosix_EDOM = (#const EDOM) sysPosix_EDQUOT = (#const EDQUOT) sysPosix_EEXIST = (#const EEXIST) sysPosix_EFAULT = (#const EFAULT) sysPosix_EFBIG = (#const EFBIG) sysPosix_EHOSTUNREACH = (#const EHOSTUNREACH) sysPosix_EIDRM = (#const EIDRM) sysPosix_EILSEQ = (#const EILSEQ) sysPosix_EINPROGRESS = (#const EINPROGRESS) sysPosix_EINTR = (#const EINTR) sysPosix_EINVAL = (#const EINVAL) sysPosix_EIO = (#const EIO) sysPosix_EISCONN = (#const EISCONN) sysPosix_EISDIR = (#const EISDIR) sysPosix_ELOOP = (#const ELOOP) sysPosix_EMFILE = (#const EMFILE) sysPosix_EMLINK = (#const EMLINK) sysPosix_EMSGSIZE = (#const EMSGSIZE) sysPosix_ENAMETOOLONG = (#const ENAMETOOLONG) sysPosix_ENETDOWN = (#const ENETDOWN) sysPosix_ENETRESET = (#const ENETRESET) sysPosix_ENETUNREACH = (#const ENETUNREACH) sysPosix_ENFILE = (#const ENFILE) sysPosix_ENOBUFS = (#const ENOBUFS) sysPosix_ENODEV = (#const ENODEV) sysPosix_ENOENT = (#const ENOENT) sysPosix_ENOEXEC = (#const ENOEXEC) sysPosix_ENOLCK = (#const ENOLCK) sysPosix_ENOMEM = (#const ENOMEM) sysPosix_ENOMSG = (#const ENOMSG) sysPosix_ENOPROTOOPT = (#const ENOPROTOOPT) sysPosix_ENOSPC = (#const ENOSPC) sysPosix_ENOSYS = (#const ENOSYS) sysPosix_ENOTCONN = (#const ENOTCONN) sysPosix_ENOTDIR = (#const ENOTDIR) sysPosix_ENOTEMPTY = (#const ENOTEMPTY) 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_EPERM = (#const EPERM) sysPosix_EPIPE = (#const EPIPE) sysPosix_EPROTONOSUPPORT = (#const EPROTONOSUPPORT) sysPosix_EPROTOTYPE = (#const EPROTOTYPE) sysPosix_ERANGE = (#const ERANGE) sysPosix_EROFS = (#const EROFS) sysPosix_ESPIPE = (#const ESPIPE) sysPosix_ESRCH = (#const ESRCH) sysPosix_ESTALE = (#const ESTALE) sysPosix_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 , sysPosix_O_RDWR , sysPosix_O_NONBLOCK , sysPosix_O_APPEND , sysPosix_O_CREAT , sysPosix_O_TRUNC , sysPosix_O_EXCL :: COpenFlags sysPosix_O_RDONLY = (#const O_RDONLY) sysPosix_O_WRONLY = (#const O_WRONLY) sysPosix_O_RDWR = ((#const O_RDONLY) .|. (#const O_WRONLY)) sysPosix_O_NONBLOCK = (#const O_NONBLOCK) sysPosix_O_APPEND = (#const O_APPEND) sysPosix_O_CREAT = (#const O_CREAT) sysPosix_O_TRUNC = (#const O_TRUNC) sysPosix_O_EXCL = (#const O_EXCL) #ifdef O_NOFOLLOW sysPosix_O_NOFOLLOW :: COpenFlags sysPosix_O_NOFOLLOW = (#const O_NOFOLLOW) #endif #ifdef O_CLOEXEC sysPosix_O_CLOEXEC :: COpenFlags sysPosix_O_CLOEXEC = (#const O_CLOEXEC) #endif sysPosix_PROT_NONE , sysPosix_PROT_READ , sysPosix_PROT_WRITE , sysPosix_PROT_EXEC :: CMemProtFlags sysPosix_PROT_NONE = (#const PROT_NONE) sysPosix_PROT_READ = (#const PROT_READ) sysPosix_PROT_WRITE = (#const PROT_WRITE) sysPosix_PROT_EXEC = (#const PROT_EXEC) sysPosix_MAP_SHARED , sysPosix_MAP_PRIVATE , sysPosix_MAP_FIXED , sysPosix_MAP_ANONYMOUS :: CMemMappingFlags sysPosix_MAP_SHARED = (#const MAP_SHARED) sysPosix_MAP_PRIVATE = (#const MAP_PRIVATE) sysPosix_MAP_FIXED = (#const MAP_FIXED) #ifdef __APPLE__ sysPosix_MAP_ANONYMOUS = (#const MAP_ANON) #else sysPosix_MAP_ANONYMOUS = (#const MAP_ANONYMOUS) #endif sysPosix_MADV_NORMAL , sysPosix_MADV_RANDOM , sysPosix_MADV_SEQUENTIAL , sysPosix_MADV_WILLNEED , sysPosix_MADV_DONTNEED :: CMemAdvice #if defined(POSIX_MADV_NORMAL) sysPosix_MADV_NORMAL = (#const POSIX_MADV_NORMAL) sysPosix_MADV_RANDOM = (#const POSIX_MADV_RANDOM) sysPosix_MADV_SEQUENTIAL = (#const POSIX_MADV_SEQUENTIAL) sysPosix_MADV_WILLNEED = (#const POSIX_MADV_WILLNEED) sysPosix_MADV_DONTNEED = (#const POSIX_MADV_DONTNEED) #else sysPosix_MADV_NORMAL = (#const MADV_NORMAL) sysPosix_MADV_RANDOM = (#const MADV_RANDOM) sysPosix_MADV_SEQUENTIAL = (#const MADV_SEQUENTIAL) sysPosix_MADV_WILLNEED = (#const MADV_WILLNEED) sysPosix_MADV_DONTNEED = (#const MADV_DONTNEED) #endif sysPosix_MS_ASYNC , sysPosix_MS_SYNC , sysPosix_MS_INVALIDATE :: CMemSyncFlags sysPosix_MS_ASYNC = (#const MS_ASYNC) sysPosix_MS_SYNC = (#const MS_SYNC) sysPosix_MS_INVALIDATE = (#const MS_INVALIDATE) foreign import ccall unsafe "mmap" sysPosixMmap :: Ptr a -> CSize -> CMemProtFlags -> CMemMappingFlags -> CFd -> COff -> IO (Ptr a) foreign import ccall unsafe "munmap" sysPosixMunmap :: Ptr a -> CSize -> IO CInt #if defined(POSIX_MADV_NORMAL) foreign import ccall unsafe "posix_madvise" sysPosixMadvise :: Ptr a -> CSize -> CMemAdvice -> IO CInt #else foreign import ccall unsafe "madvise" sysPosixMadvise :: Ptr a -> CSize -> CMemAdvice -> IO CInt #endif foreign import ccall unsafe "msync" sysPosixMsync :: Ptr a -> CSize -> CMemSyncFlags -> IO CInt foreign import ccall unsafe "mprotect" sysPosixMprotect :: Ptr a -> CSize -> CMemProtFlags -> IO CInt #ifndef __HAIKU__ foreign import ccall unsafe "mlock" sysPosixMlock :: Ptr a -> CSize -> IO CInt #else sysPosixMlock :: Ptr a -> CSize -> IO CInt sysPosixMlock _ _ = return (-1) #endif #ifndef __HAIKU__ foreign import ccall unsafe "munlock" sysPosixMunlock :: Ptr a -> CSize -> IO CInt #else sysPosixMunlock :: Ptr a -> CSize -> IO CInt sysPosixMunlock _ _ = return (-1) #endif sysPosix_SC_PAGESIZE :: CSysconfName sysPosix_SC_PAGESIZE = (#const _SC_PAGESIZE) foreign import ccall unsafe "sysconf" sysPosixSysconf :: CSysconfName -> CLong -------------------------------------------------------------------------------- -- files -------------------------------------------------------------------------------- foreign import ccall unsafe "open" sysPosixOpen :: Ptr CChar -> COpenFlags -> CMode -> IO CFd foreign import ccall unsafe "openat" sysPosixOpenAt :: CFd -> Ptr CChar -> COpenFlags -> CMode -> IO CFd foreign import ccall unsafe "close" sysPosixClose :: CFd -> IO CInt foreign import capi "fcntl.h fcntl" sysPosixFnctlNoArg :: CFd -> CInt -> IO CInt foreign import capi "fcntl.h fcntl" sysPosixFnctlPtr :: CFd -> CInt -> Ptr a -> IO CInt foreign import ccall unsafe "ftruncate" sysPosixFtruncate :: CFd -> COff -> IO CInt -------------------------------------------------------------------------------- -- directories -------------------------------------------------------------------------------- foreign import ccall unsafe "opendir" sysPosixOpendir :: Ptr CChar -> IO (Ptr CDir) foreign import ccall unsafe "fdopendir" sysPosixFdopendir :: CFd -> IO (Ptr CDir) foreign import ccall unsafe "readdir" sysPosixReaddir :: Ptr CDir -> IO (Ptr CDirent) foreign import ccall unsafe "readdir_r" sysPosixReaddirR :: Ptr CDir -> Ptr CDirent -> Ptr (Ptr CDirent) -> IO CInt foreign import ccall unsafe "telldir" sysPosixTelldir :: Ptr CDir -> IO CLong foreign import ccall unsafe "seekdir" sysPosixSeekdir :: Ptr CDir -> CLong -> IO () foreign import ccall unsafe "rewinddir" sysPosixRewinddir :: Ptr CDir -> IO () foreign import ccall unsafe "closedir" sysPosixClosedir :: Ptr CDir -> IO CInt foreign import ccall unsafe "dirfd" sysPosixDirfd :: Ptr CDir -> IO CFd foundation-0.0.23/Foundation/System/Bindings/PosixDef.hsc0000644000000000000000000000073213415353646021513 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.PosixDef ( CErrno , CFd , CMemProtFlags , CMemMappingFlags , CMemAdvice , CMemSyncFlags , CSysconfName , COpenFlags , COff(..) , CMode(..) ) where import Basement.Compat.C.Types type CErrno = CInt type CFd = CInt type CMemProtFlags = CInt type CMemMappingFlags = CInt type CMemAdvice = CInt type CMemSyncFlags = CInt type CSysconfName = CInt type COpenFlags = CInt foundation-0.0.23/Foundation/System/Bindings/Linux.hsc0000644000000000000000000000613213415353646021071 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Foundation.System.Bindings.Linux -- Copyright : (c) Vincent Hanquez 2014-2017 -- License : BSD-style -- -- Maintainer : Vincent Hanquez -- Stability : provisional -- Portability : non-portable (requires Linux) -- -- Functions defined only for linux -- ----------------------------------------------------------------------------- {-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Linux where import Basement.Compat.Base import Basement.Compat.C.Types import Foundation.System.Bindings.PosixDef #define __USE_GNU #include #include #include type CInotifyFlags = CInt type CInotifyMask = CInt type CWatchDescriptor = CInt sysLinux_O_TMPFILE :: COpenFlags #ifdef __O_TMPFILE sysLinux_O_TMPFILE = (#const __O_TMPFILE) #else sysLinux_O_TMPFILE = 0 #endif #ifdef IN_NONBLOCK sysLinux_IN_NONBLOCK :: CInotifyFlags sysLinux_IN_NONBLOCK = (#const IN_NONBLOCK) #endif #ifdef IN_CLOEXEC sysLinux_IN_CLOEXEC :: CInotifyFlags sysLinux_IN_CLOEXEC = (#const IN_CLOEXEC) #endif sysLinux_IN_ACCESS , sysLinux_IN_ATTRIB , sysLinux_IN_CLOSE_WRITE , sysLinux_IN_CLOSE_NOWRITE , sysLinux_IN_CREATE , sysLinux_IN_DELETE , sysLinux_IN_DELETE_SELF , sysLinux_IN_MODIFY , sysLinux_IN_MOVE_SELF , sysLinux_IN_MOVED_FROM , sysLinux_IN_MOVED_TO :: CInotifyMask sysLinux_IN_ACCESS = (#const IN_ACCESS) sysLinux_IN_ATTRIB = (#const IN_ATTRIB) sysLinux_IN_CLOSE_WRITE = (#const IN_CLOSE_WRITE) sysLinux_IN_CLOSE_NOWRITE = (#const IN_CLOSE_NOWRITE) sysLinux_IN_CREATE = (#const IN_CREATE) sysLinux_IN_DELETE = (#const IN_DELETE) sysLinux_IN_DELETE_SELF = (#const IN_DELETE_SELF) sysLinux_IN_MODIFY = (#const IN_MODIFY) sysLinux_IN_MOVE_SELF = (#const IN_MOVE_SELF) sysLinux_IN_MOVED_FROM = (#const IN_MOVED_FROM) sysLinux_IN_MOVED_TO = (#const IN_MOVED_TO) -- extra mask at add_watch time sysLinux_IN_OPEN , sysLinux_IN_DONT_FOLLOW , sysLinux_IN_MASK_ADD , sysLinux_IN_ONESHOT , sysLinux_IN_ONLYDIR :: CInotifyMask sysLinux_IN_OPEN = (#const IN_OPEN) sysLinux_IN_DONT_FOLLOW = (#const IN_DONT_FOLLOW) sysLinux_IN_MASK_ADD = (#const IN_MASK_ADD) sysLinux_IN_ONESHOT = (#const IN_ONESHOT) sysLinux_IN_ONLYDIR = (#const IN_ONLYDIR) #ifdef IN_EXCL_UNLINK sysLinux_IN_EXCL_UNLINK :: CInotifyMask sysLinux_IN_EXCL_UNLINK = (#const IN_EXCL_UNLINK) #endif -- only found in mask sysLinux_IN_IGNORED , sysLinux_IN_ISDIR , sysLinux_IN_Q_OVERFLOW , sysLinux_IN_UNMOUNT :: CInotifyMask sysLinux_IN_IGNORED = (#const IN_IGNORED) sysLinux_IN_ISDIR = (#const IN_ISDIR) sysLinux_IN_Q_OVERFLOW = (#const IN_Q_OVERFLOW) sysLinux_IN_UNMOUNT = (#const IN_UNMOUNT) cinotifyEventSize :: CSize cinotifyEventSize = 16 foreign import ccall unsafe "inotify_init1" sysLinuxInotifyInit :: CInotifyFlags -> IO CFd foreign import ccall unsafe "inotify_add_watch" sysLinuxInotifyAddWatch :: CFd -> Ptr CChar -> CInotifyMask -> IO CWatchDescriptor foreign import ccall unsafe "inotify_rm_watch" sysLinuxInotifyRmWatch :: CFd -> CWatchDescriptor -> IO Int foundation-0.0.23/Foundation/System/Bindings/Macos.hsc0000644000000000000000000000224013415353646021030 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Macos where import Basement.Compat.Base import Basement.Compat.C.Types import Foundation.System.Bindings.PosixDef import Basement.Types.OffsetSize #include #include #include #include #include #include sysMacos_O_SHLOCK , sysMacos_O_EXLOCK , sysMacos_O_SYMLINK , sysMacos_O_EVTONLY :: COpenFlags sysMacos_O_SHLOCK = (#const O_SHLOCK) sysMacos_O_EXLOCK = (#const O_EXLOCK) sysMacos_O_SYMLINK = (#const O_SYMLINK) sysMacos_O_EVTONLY = (#const O_EVTONLY) data MachTimebaseInfo size_MachTimebaseInfo :: CSize size_MachTimebaseInfo = #const sizeof(mach_timebase_info_data_t) ofs_MachTimebaseInfo_numer :: Offset Word8 ofs_MachTimebaseInfo_numer = Offset (#offset mach_timebase_info_data_t, numer) ofs_MachTimebaseInfo_denom :: Offset Word8 ofs_MachTimebaseInfo_denom = Offset (#offset mach_timebase_info_data_t, denom) foreign import ccall unsafe "mach_absolute_time" sysMacos_absolute_time :: IO Word64 foreign import ccall unsafe "mach_timebase_info" sysMacos_timebase_info :: Ptr MachTimebaseInfo -> IO () foundation-0.0.23/Foundation/Tuple.hs0000644000000000000000000000646513415353646015710 0ustar0000000000000000-- | -- Module : Foundation.Tuple -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Foundation.Tuple ( Tuple2(..) , Tuple3(..) , Tuple4(..) , Fstable(..) , Sndable(..) , Thdable(..) ) where import Basement.Compat.Base import Basement.Compat.Bifunctor import Foundation.Primitive -- | Strict tuple (a,b) data Tuple2 a b = Tuple2 !a !b deriving (Show,Eq,Ord,Typeable,Data,Generic) instance (NormalForm a, NormalForm b) => NormalForm (Tuple2 a b) where toNormalForm (Tuple2 a b) = toNormalForm a `seq` toNormalForm b instance Bifunctor Tuple2 where bimap f g (Tuple2 a b) = Tuple2 (f a) (g b) -- | Strict tuple (a,b,c) data Tuple3 a b c = Tuple3 !a !b !c deriving (Show,Eq,Ord,Typeable,Data,Generic) instance (NormalForm a, NormalForm b, NormalForm c) => NormalForm (Tuple3 a b c) where toNormalForm (Tuple3 a b c) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c -- | Strict tuple (a,b,c,d) data Tuple4 a b c d = Tuple4 !a !b !c !d deriving (Show,Eq,Ord,Typeable,Data,Generic) instance (NormalForm a, NormalForm b, NormalForm c, NormalForm d) => NormalForm (Tuple4 a b c d) where toNormalForm (Tuple4 a b c d) = toNormalForm a `seq` toNormalForm b `seq` toNormalForm c `seq` toNormalForm d -- | Class of product types that have a first element class Fstable a where type ProductFirst a fst :: a -> ProductFirst a -- | Class of product types that have a second element class Sndable a where type ProductSecond a snd :: a -> ProductSecond a -- | Class of product types that have a third element class Thdable a where type ProductThird a thd :: a -> ProductThird a instance Fstable (a,b) where type ProductFirst (a,b) = a fst (a,_) = a instance Fstable (a,b,c) where type ProductFirst (a,b,c) = a fst (a,_,_) = a instance Fstable (a,b,c,d) where type ProductFirst (a,b,c,d) = a fst (a,_,_,_) = a instance Fstable (Tuple2 a b) where type ProductFirst (Tuple2 a b) = a fst (Tuple2 a _) = a instance Fstable (Tuple3 a b c) where type ProductFirst (Tuple3 a b c) = a fst (Tuple3 a _ _) = a instance Fstable (Tuple4 a b c d) where type ProductFirst (Tuple4 a b c d) = a fst (Tuple4 a _ _ _) = a instance Sndable (a,b) where type ProductSecond (a,b) = b snd (_,b) = b instance Sndable (a,b,c) where type ProductSecond (a,b,c) = b snd (_,b,_) = b instance Sndable (a,b,c,d) where type ProductSecond (a,b,c,d) = b snd (_,b,_,_) = b instance Sndable (Tuple2 a b) where type ProductSecond (Tuple2 a b) = b snd (Tuple2 _ b) = b instance Sndable (Tuple3 a b c) where type ProductSecond (Tuple3 a b c) = b snd (Tuple3 _ b _) = b instance Sndable (Tuple4 a b c d) where type ProductSecond (Tuple4 a b c d) = b snd (Tuple4 _ b _ _) = b instance Thdable (a,b,c) where type ProductThird (a,b,c) = c thd (_,_,c) = c instance Thdable (a,b,c,d) where type ProductThird (a,b,c,d) = c thd (_,_,c,_) = c instance Thdable (Tuple3 a b c) where type ProductThird (Tuple3 a b c) = c thd (Tuple3 _ _ c) = c instance Thdable (Tuple4 a b c d) where type ProductThird (Tuple4 a b c d) = c thd (Tuple4 _ _ c _) = c foundation-0.0.23/Foundation/Hashing/FNV.hs0000644000000000000000000001560413415353646016624 0ustar0000000000000000-- | -- Module : Foundation.Hashing.FNV.FNV -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions) -- -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} module Foundation.Hashing.FNV ( -- * types FNV1Hash32(..) , FNV1Hash64(..) , FNV1_32 , FNV1a_32 , FNV1_64 , FNV1a_64 ) where import Basement.Block (Block(..)) import Basement.Compat.Base import qualified Basement.UArray as A import Basement.Types.OffsetSize import Basement.PrimType import Basement.IntegralConv import Foundation.Numerical import Foundation.Hashing.Hasher import Data.Bits import GHC.ST -- | FNV1(a) hash (32 bit variants) newtype FNV1Hash32 = FNV1Hash32 Word32 deriving (Show,Eq,Ord) -- | FNV1(a) hash (64 bit variants) newtype FNV1Hash64 = FNV1Hash64 Word64 deriving (Show,Eq,Ord) xor32 :: Word -> Word8 -> Word xor32 !a !b = a `xor` integralUpsize b {-# INLINE xor32 #-} xor64 :: Word64 -> Word8 -> Word64 xor64 !a !b = a `xor` integralUpsize b {-# INLINE xor64 #-} -- | FNV1 32 bit state newtype FNV1_32 = FNV1_32 Word -- | FNV1 64 bit state newtype FNV1_64 = FNV1_64 Word64 -- | FNV1a 32 bit state newtype FNV1a_32 = FNV1a_32 Word -- | FNV1a 64 bit state newtype FNV1a_64 = FNV1a_64 Word64 fnv1_32_Mix8 :: Word8 -> FNV1_32 -> FNV1_32 fnv1_32_Mix8 !w (FNV1_32 acc) = FNV1_32 (0x01000193 * acc `xor32` w) {-# INLINE fnv1_32_Mix8 #-} fnv1a_32_Mix8 :: Word8 -> FNV1a_32 -> FNV1a_32 fnv1a_32_Mix8 !w (FNV1a_32 acc) = FNV1a_32 (0x01000193 * (acc `xor32` w)) {-# INLINE fnv1a_32_Mix8 #-} fnv1_64_Mix8 :: Word8 -> FNV1_64 -> FNV1_64 fnv1_64_Mix8 !w (FNV1_64 acc) = FNV1_64 (0x100000001b3 * acc `xor64` w) {-# INLINE fnv1_64_Mix8 #-} fnv1a_64_Mix8 :: Word8 -> FNV1a_64 -> FNV1a_64 fnv1a_64_Mix8 !w (FNV1a_64 acc) = FNV1a_64 (0x100000001b3 * (acc `xor64` w)) {-# INLINE fnv1a_64_Mix8 #-} 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 (integralDownsize 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 (integralDownsize 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 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 w hashMix8 = fnv1a_64_Mix8 hashMixBytes = fnv1a_64_mixBa -- | compute FNV1 (32 bit variant) of a raw piece of memory fnv1_32_mixBa :: PrimType a => A.UArray a -> FNV1_32 -> FNV1_32 fnv1_32_mixBa baA !initialState = A.unsafeDewrap goVec goAddr ba where ba :: A.UArray Word8 ba = A.unsafeRecast baA goVec :: Block Word8 -> Offset Word8 -> FNV1_32 goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc) {-# INLINE goVec #-} goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1_32 goAddr (Ptr ptr) !start = return $ loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc) {-# INLINE goAddr #-} -- | compute FNV1a (32 bit variant) of a raw piece of memory fnv1a_32_mixBa :: PrimType a => A.UArray a -> FNV1a_32 -> FNV1a_32 fnv1a_32_mixBa baA !initialState = A.unsafeDewrap goVec goAddr ba where ba :: A.UArray Word8 ba = A.unsafeRecast baA goVec :: Block Word8 -> Offset Word8 -> FNV1a_32 goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc) {-# INLINE goVec #-} goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1a_32 goAddr (Ptr ptr) !start = return $ loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc) {-# INLINE goAddr #-} -- | compute FNV1 (64 bit variant) of a raw piece of memory fnv1_64_mixBa :: PrimType a => A.UArray a -> FNV1_64 -> FNV1_64 fnv1_64_mixBa baA !initialState = A.unsafeDewrap goVec goAddr ba where ba :: A.UArray Word8 ba = A.unsafeRecast baA goVec :: Block Word8 -> Offset Word8 -> FNV1_64 goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc) {-# INLINE goVec #-} goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1_64 goAddr (Ptr ptr) !start = return $ loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc) {-# INLINE goAddr #-} -- | compute FNV1a (64 bit variant) of a raw piece of memory fnv1a_64_mixBa :: PrimType a => A.UArray a -> FNV1a_64 -> FNV1a_64 fnv1a_64_mixBa baA !initialState = A.unsafeDewrap goVec goAddr ba where ba :: A.UArray Word8 ba = A.unsafeRecast baA goVec :: Block Word8 -> Offset Word8 -> FNV1a_64 goVec (Block !ma) !start = loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primBaIndex ma idx) acc) {-# INLINE goVec #-} goAddr :: Ptr Word8 -> Offset Word8 -> ST s FNV1a_64 goAddr (Ptr ptr) !start = return $ loop start initialState where !len = start `offsetPlusE` A.length ba loop !idx !acc | idx >= len = acc | otherwise = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc) {-# INLINE goAddr #-} foundation-0.0.23/Foundation/Hashing/SipHash.hs0000644000000000000000000003050213415353646017524 0ustar0000000000000000-- | -- Module : Foundation.Hashing.SipHash -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- provide the SipHash algorithm. -- reference: -- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} module Foundation.Hashing.SipHash ( SipKey(..) , SipHash(..) , Sip1_3 , Sip2_4 ) where import Data.Bits import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.PrimType import Basement.Cast (cast) import Basement.IntegralConv import Foundation.Hashing.Hasher import Basement.Block (Block(..)) import qualified Basement.UArray as A import Foundation.Array import Foundation.Numerical import Foundation.Bits import qualified Prelude import GHC.ST -- | SigHash Key data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 -- | Siphash Hash value newtype SipHash = SipHash Word64 deriving (Show,Eq,Ord) -- | Sip State 2-4 (2 compression rounds, 4 digest rounds) newtype Sip2_4 = Sip2_4 Sip -- | Sip State 1-3 (1 compression rounds, 3 digest rounds) newtype Sip1_3 = Sip1_3 Sip 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 hashMix64 w (Sip2_4 st) = Sip2_4 $ mix64 2 w st hashMixBytes ba (Sip2_4 st) = Sip2_4 $ mixBa 2 ba st 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 hashMix64 w (Sip1_3 st) = Sip1_3 $ mix64 1 w st hashMixBytes ba (Sip1_3 st) = Sip1_3 $ mixBa 1 ba st data Sip = Sip !InternalState !SipIncremental !(CountOf Word8) data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 data SipIncremental = SipIncremental0 | SipIncremental1 {-# UNPACK #-} !Word64 | SipIncremental2 {-# UNPACK #-} !Word64 | SipIncremental3 {-# UNPACK #-} !Word64 | SipIncremental4 {-# UNPACK #-} !Word64 | SipIncremental5 {-# UNPACK #-} !Word64 | SipIncremental6 {-# UNPACK #-} !Word64 | SipIncremental7 {-# UNPACK #-} !Word64 newSipState :: SipKey -> Sip newSipState (SipKey k0 k1) = Sip st SipIncremental0 0 where st = InternalState (k0 `xor` 0x736f6d6570736575) (k1 `xor` 0x646f72616e646f6d) (k0 `xor` 0x6c7967656e657261) (k1 `xor` 0x7465646279746573) mix8Prim :: Int -> Word8 -> InternalState -> SipIncremental -> (InternalState, SipIncremental) mix8Prim !c !w !ist !incremental = case incremental of SipIncremental7 acc -> (process c ist ((acc `unsafeShiftL` 8) .|. Prelude.fromIntegral w), SipIncremental0) SipIncremental6 acc -> doAcc SipIncremental7 acc SipIncremental5 acc -> doAcc SipIncremental6 acc SipIncremental4 acc -> doAcc SipIncremental5 acc SipIncremental3 acc -> doAcc SipIncremental4 acc SipIncremental2 acc -> doAcc SipIncremental3 acc SipIncremental1 acc -> doAcc SipIncremental2 acc SipIncremental0 -> (ist, SipIncremental1 $ Prelude.fromIntegral w) where doAcc constr acc = (ist , constr ((acc .<<. 8) .|. Prelude.fromIntegral w)) mix8 :: Int -> Word8 -> Sip -> Sip mix8 !c !w (Sip ist incremental len) = case incremental of SipIncremental7 acc -> Sip (process c ist ((acc .<<. 8) .|. Prelude.fromIntegral w)) SipIncremental0 (len+1) SipIncremental6 acc -> doAcc SipIncremental7 acc SipIncremental5 acc -> doAcc SipIncremental6 acc SipIncremental4 acc -> doAcc SipIncremental5 acc SipIncremental3 acc -> doAcc SipIncremental4 acc SipIncremental2 acc -> doAcc SipIncremental3 acc SipIncremental1 acc -> doAcc SipIncremental2 acc SipIncremental0 -> Sip ist (SipIncremental1 $ Prelude.fromIntegral w) (len+1) where doAcc constr acc = Sip ist (constr ((acc .<<. 8) .|. Prelude.fromIntegral w)) (len+1) mix32 :: Int -> Word32 -> Sip -> Sip mix32 !c !w (Sip ist incremental len) = case incremental of SipIncremental0 -> Sip ist (SipIncremental4 $ Prelude.fromIntegral w) (len+4) SipIncremental1 acc -> consume acc 32 SipIncremental5 SipIncremental2 acc -> consume acc 32 SipIncremental6 SipIncremental3 acc -> consume acc 32 SipIncremental7 SipIncremental4 acc -> Sip (process c ist ((acc .<<. 32) .|. Prelude.fromIntegral w)) SipIncremental0 (len+4) SipIncremental5 acc -> consumeProcess acc 24 8 SipIncremental1 SipIncremental6 acc -> consumeProcess acc 16 16 SipIncremental2 SipIncremental7 acc -> consumeProcess acc 8 24 SipIncremental3 where consume acc n constr = Sip ist (constr ((acc .<<. n) .&. Prelude.fromIntegral w)) (len+4) {-# INLINE consume #-} consumeProcess acc n x constr = Sip (process c ist ((acc .<<. n) .|. (Prelude.fromIntegral w .>>. x))) (constr (Prelude.fromIntegral w .&. andMask64 n)) (len+4) {-# INLINE consumeProcess #-} mix64 :: Int -> Word64 -> Sip -> Sip mix64 !c !w (Sip ist incremental len) = case incremental of SipIncremental0 -> Sip (process c ist w) SipIncremental0 (len+8) SipIncremental1 acc -> consume acc 56 8 SipIncremental1 SipIncremental2 acc -> consume acc 48 16 SipIncremental2 SipIncremental3 acc -> consume acc 40 24 SipIncremental3 SipIncremental4 acc -> consume acc 32 32 SipIncremental4 SipIncremental5 acc -> consume acc 24 40 SipIncremental5 SipIncremental6 acc -> consume acc 16 48 SipIncremental6 SipIncremental7 acc -> consume acc 8 56 SipIncremental7 where consume acc n x constr = Sip (process c ist ((acc .<<. n) .|. ((w .>>. x) .&. andMask64 n))) (constr $ acc .&. andMask64 x) (len+8) {-# INLINE consume #-} finish :: Int -> Int -> Sip -> SipHash finish !c !d (Sip ist incremental (CountOf len)) = finalize d $ case incremental of SipIncremental0 -> process c ist lenMask SipIncremental1 acc -> process c ist (lenMask .|. acc) SipIncremental2 acc -> process c ist (lenMask .|. acc) SipIncremental3 acc -> process c ist (lenMask .|. acc) SipIncremental4 acc -> process c ist (lenMask .|. acc) SipIncremental5 acc -> process c ist (lenMask .|. acc) SipIncremental6 acc -> process c ist (lenMask .|. acc) SipIncremental7 acc -> process c ist (lenMask .|. acc) where lenMask = (wlen .&. 0xff) .<<. 56 wlen = cast (integralUpsize len :: Int64) :: Word64 -- | same as 'hash', except also specifies the number of sipround iterations for compression (C) and digest (D). mixBa :: PrimType a => Int -> UArray a -> Sip -> Sip mixBa !c !array (Sip initSt initIncr currentLen) = A.unsafeDewrap goVec goAddr array8 where totalLen = A.length array8 array8 = A.unsafeRecast array goVec :: Block Word8 -> Offset Word8 -> Sip goVec (Block ba) start = loop8 initSt initIncr start totalLen where loop8 !st !incr _ 0 = Sip st incr (currentLen + totalLen) loop8 !st SipIncremental0 !ofs !l = case l - 8 of Nothing -> loop1 st SipIncremental0 ofs l Just l8 -> let v = to64 56 (primBaIndex ba ofs) .|. to64 48 (primBaIndex ba (ofs + Offset 1)) .|. to64 40 (primBaIndex ba (ofs + Offset 2)) .|. to64 32 (primBaIndex ba (ofs + Offset 3)) .|. to64 24 (primBaIndex ba (ofs + Offset 4)) .|. to64 16 (primBaIndex ba (ofs + Offset 5)) .|. to64 8 (primBaIndex ba (ofs + Offset 6)) .|. to64 0 (primBaIndex ba (ofs + Offset 7)) in loop8 (process c st v) SipIncremental0 (start + Offset 8) l8 loop8 !st !incr !ofs !l = loop1 st incr ofs l loop1 !st !incr !ofs !l = case l - 1 of Nothing -> Sip st incr (currentLen + totalLen) Just l1 -> let (!st', !incr') = mix8Prim c (primBaIndex ba ofs) st incr in loop1 st' incr' (ofs + Offset 1) l1 to64 :: Int -> Word8 -> Word64 to64 0 !v = Prelude.fromIntegral v to64 !s !v = Prelude.fromIntegral v .<<. s goAddr :: Ptr Word8 -> Offset Word8 -> ST s Sip goAddr (Ptr ptr) start = return $ loop8 initSt initIncr start totalLen where loop8 !st !incr _ 0 = Sip st incr (currentLen + totalLen) loop8 !st SipIncremental0 !ofs !l = case l - 8 of Nothing -> loop1 st SipIncremental0 ofs l Just l8 -> let v = to64 56 (primAddrIndex ptr ofs) .|. to64 48 (primAddrIndex ptr (ofs + Offset 1)) .|. to64 40 (primAddrIndex ptr (ofs + Offset 2)) .|. to64 32 (primAddrIndex ptr (ofs + Offset 3)) .|. to64 24 (primAddrIndex ptr (ofs + Offset 4)) .|. to64 16 (primAddrIndex ptr (ofs + Offset 5)) .|. to64 8 (primAddrIndex ptr (ofs + Offset 6)) .|. to64 0 (primAddrIndex ptr (ofs + Offset 7)) in loop8 (process c st v) SipIncremental0 (start + Offset 8) l8 -- (l - 8) loop8 !st !incr !ofs !l = loop1 st incr ofs l loop1 !st !incr !ofs !l = case l - 1 of Nothing -> Sip st incr (currentLen + totalLen) Just l1 -> let (!st', !incr') = mix8Prim c (primAddrIndex ptr ofs) st incr in loop1 st' incr' (ofs + Offset 1) l1 doRound :: InternalState -> InternalState doRound (InternalState !v0 !v1 !v2 !v3) = let !v0' = v0 + v1 !v2' = v2 + v3 !v1' = v1 `rotateL` 13 !v3' = v3 `rotateL` 16 !v1'' = v1' `xor` v0' !v3'' = v3' `xor` v2' !v0'' = v0' `rotateL` 32 !v2'' = v2' + v1'' !v0''' = v0'' + v3'' !v1''' = v1'' `rotateL` 17 !v3''' = v3'' `rotateL` 21 !v1'''' = v1''' `xor` v2'' !v3'''' = v3''' `xor` v0''' !v2''' = v2'' `rotateL` 32 in InternalState v0''' v1'''' v2''' v3'''' {-# INLINE doRound #-} process :: Int -> InternalState -> Word64 -> InternalState process !c !istate !m = postInject $! runRoundsCompression $! preInject istate where preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m) postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3 runRoundsCompression st | c == 2 = doRound $! doRound st | otherwise = loopRounds c st {-# INLINE process #-} finalize :: Int -> InternalState -> SipHash finalize !d !istate = getDigest $! runRoundsDigest $! preInject istate where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3) preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3 runRoundsDigest st | d == 4 = doRound $! doRound $! doRound $! doRound st | otherwise = loopRounds d st {-# INLINE finalize #-} loopRounds :: Int -> InternalState -> InternalState loopRounds 1 !v = doRound v loopRounds n !v = loopRounds (n-1) (doRound v) {-# INLINE loopRounds #-} andMask64 :: Int -> Word64 andMask64 64 = 0xffffffffffffffff andMask64 56 = 0x00ffffffffffffff andMask64 48 = 0x0000ffffffffffff andMask64 40 = 0x000000ffffffffff andMask64 32 = 0x00000000ffffffff andMask64 24 = 0x0000000000ffffff andMask64 16 = 0x000000000000ffff andMask64 8 = 0x00000000000000ff andMask64 n = (1 .<<. n) - (1 :: Word64) {-# INLINE andMask64 #-} foundation-0.0.23/Foundation/Hashing/Hasher.hs0000644000000000000000000000425613415353646017406 0ustar0000000000000000module Foundation.Hashing.Hasher ( Hasher(..) ) where import Basement.Compat.Base import Basement.IntegralConv import Foundation.Array (UArray) import qualified Basement.UArray as A import Data.Bits -- | Incremental Hashing state. Represent an hashing algorithm -- -- the base primitive of this class is `hashMix8`, append -- mix a Word8 in the state -- -- 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, 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 -- | Mix a Word8 (Byte) into the state and return the new state hashMix8 :: Word8 -> st -> st -- | Mix a Word16 into the state and return the new state hashMix16 :: Word16 -> st -> st hashMix16 w st = hashMix8 w2 $ hashMix8 w1 st where !w1 = integralDownsize (w `unsafeShiftR` 8) !w2 = integralDownsize w -- | Mix a Word32 into the state and return the new state hashMix32 :: Word32 -> st -> st hashMix32 w st = hashMix8 w4 $ hashMix8 w3 $ hashMix8 w2 $ hashMix8 w1 st where !w1 = integralDownsize (w `unsafeShiftR` 24) !w2 = integralDownsize (w `unsafeShiftR` 16) !w3 = integralDownsize (w `unsafeShiftR` 8) !w4 = integralDownsize w -- | Mix a Word64 into the state and return the new state hashMix64 :: Word64 -> st -> st hashMix64 w st = hashMix32 w2 $ hashMix32 w1 st where !w1 = integralDownsize (w `unsafeShiftR` 32) !w2 = integralDownsize w -- | Mix an arbitrary sized unboxed array and return the new state hashMixBytes :: A.PrimType e => UArray e -> st -> st hashMixBytes ba st = A.foldl' (flip hashMix8) st (A.unsafeRecast ba) foundation-0.0.23/Foundation/Hashing/Hashable.hs0000644000000000000000000001110713415353646017674 0ustar0000000000000000-- | -- Module : Foundation.Hashing.Hashable -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- provide the SipHash algorithm. -- reference: -- module Foundation.Hashing.Hashable ( Hashable(..) ) where import Basement.Imports import Basement.Cast (cast) import Basement.Compat.Natural import Basement.Types.Word128 import Basement.Types.Word256 import Basement.IntegralConv import Basement.Numerical.Multiplicative import qualified Basement.BoxedArray as A import Foundation.Tuple import Foundation.String import Foundation.Collection.Foldable import Foundation.Hashing.Hasher -- | Type with the ability to be hashed -- -- Hashable doesn't have any specific rules, and it's -- made for raw speed. More specifically don't expect different -- type representing the same data to hash to the same value -- -- > hashMix (1 :: Integer) /= hashMix (1 :: Word8) -- True class Hashable a where hashMix :: Hasher st => a -> st -> st -- specific type instances instance Hashable Word8 where hashMix w = hashMix8 w instance Hashable Word16 where hashMix w = hashMix16 w instance Hashable Word32 where hashMix w = hashMix32 w instance Hashable Word64 where hashMix w = hashMix64 w instance Hashable Word128 where hashMix (Word128 w1 w2) = hashMix64 w2 . hashMix64 w1 instance Hashable Word256 where hashMix (Word256 w1 w2 w3 w4) = hashMix64 w4 . hashMix64 w3 . hashMix64 w2 . hashMix64 w1 instance Hashable Natural where hashMix n iacc | n == 0 = hashMix8 0 iacc | otherwise = loop n iacc where loop 0 acc = acc loop w acc = let b = integralDownsize (w :: Natural) :: Word8 in loop (w `div` 256) (hashMix8 b acc) instance Hashable Int8 where hashMix w = hashMix8 (cast w) instance Hashable Int16 where hashMix w = hashMix16 (cast w) instance Hashable Int32 where hashMix w = hashMix32 (cast w) instance Hashable Int64 where hashMix w = hashMix64 (cast w) instance Hashable Integer where hashMix i iacc | i == 0 = hashMix8 0 iacc | i < 0 = loop (integerToNatural i) (hashMix8 1 iacc) | otherwise = loop (integerToNatural i) (hashMix8 0 iacc) where loop :: Hasher st => Natural -> st -> st loop 0 acc = acc loop w acc = let b = integralDownsize w :: Word8 in loop (w `div` 256) (hashMix8 b acc) instance Hashable String where hashMix s = hashMixBytes (toBytes UTF8 s) -- collection type instances instance PrimType a => Hashable (UArray a) where hashMix ba = hashMixBytes ba instance Hashable a => Hashable (A.Array a) where hashMix arr st = A.foldl' (flip hashMix) st arr -- combined instances instance Hashable a => Hashable [a] where hashMix ba st = foldl' (flip hashMix) st ba instance (Hashable a, Hashable b) => Hashable (a,b) where hashMix (a,b) = hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where hashMix (a,b,c) = hashMix c . hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where hashMix (a,b,c,d) = hashMix d . hashMix c . hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where hashMix (a,b,c,d,e) = hashMix e . hashMix d . hashMix c . hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e, Hashable f) => Hashable (a,b,c,d,e,f) where hashMix (a,b,c,d,e,f) = hashMix f . hashMix e . hashMix d . hashMix c . hashMix b . hashMix a instance (Hashable a, Hashable b) => Hashable (Tuple2 a b) where hashMix (Tuple2 a b) = hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c) => Hashable (Tuple3 a b c) where hashMix (Tuple3 a b c) = hashMix c . hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (Tuple4 a b c d) where hashMix (Tuple4 a b c d) = hashMix d . hashMix c . hashMix b . hashMix a {- instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (Tuple5 a b c d e) where hashMix (Tuple5 a b c d e) = hashMix e . hashMix d . hashMix c . hashMix b . hashMix a instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e, Hashable f) => Hashable (Tuple6 a b c d e f) where hashMix (Tuple6 a b c d e f) = hashMix f . hashMix e . hashMix d . hashMix c . hashMix b . hashMix a -} foundation-0.0.23/Foundation/Check/Gen.hs0000644000000000000000000000460413415353646016336 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Foundation.Check.Gen ( Gen , runGen , GenParams(..) , GenRng , genRng , genWithRng , genWithParams ) where import Basement.Imports import Foundation.Collection import Foundation.Random import qualified Foundation.Random.XorShift as XorShift import Foundation.String import Foundation.Numerical import Foundation.Hashing.SipHash import Foundation.Hashing.Hasher data GenParams = GenParams { genMaxSizeIntegral :: Word -- maximum number of bytes , genMaxSizeArray :: Word -- number of elements, as placeholder , genMaxSizeString :: Word -- maximum number of chars } newtype GenRng = GenRng XorShift.State type GenSeed = Word64 genRng :: GenSeed -> [String] -> (Word64 -> GenRng) genRng seed groups = \iteration -> GenRng $ XorShift.initialize rngSeed (rngSeed * iteration) where (SipHash rngSeed) = hashEnd $ hashMixBytes hashData iHashState hashData = toBytes UTF8 $ intercalate "::" groups iHashState :: Sip1_3 iHashState = hashNewParam (SipKey seed 0x12345678) genGenerator :: GenRng -> (GenRng, GenRng) genGenerator (GenRng rng) = let (newSeed1, rngNext) = randomGenerateWord64 rng (newSeed2, rngNext') = randomGenerateWord64 rngNext in (GenRng $ XorShift.initialize newSeed1 newSeed2, 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 genWithParams :: (GenParams -> Gen a) -> Gen a genWithParams f = Gen $ \rng params -> runGen (f params) rng params foundation-0.0.23/Foundation/Check/Print.hs0000644000000000000000000000615013415353646016717 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} module Foundation.Check.Print ( propertyToResult , PropertyResult(..) , diffBlame ) where import Foundation.Check.Property import Foundation.Check.Types import Basement.Imports import Foundation.Collection import Basement.Compat.Bifunctor (bimap) import Foundation.Numerical propertyToResult :: PropertyTestArg -> (PropertyResult, Bool) propertyToResult propertyTestArg = let args = propertyGetArgs propertyTestArg checks = getChecks propertyTestArg in if checkHasFailed checks then printError args checks else (PropertySuccess, not (null args)) where printError args checks = (PropertyFailed (mconcat $ loop 1 args), False) where loop :: Word -> [String] -> [String] loop _ [] = printChecks checks loop !i (a:as) = "parameter " <> show i <> " : " <> a <> "\n" : loop (i+1) as printChecks (PropertyBinaryOp True _ _ _) = [] printChecks (PropertyBinaryOp False n a b) = [ "Property `a " <> n <> " b' failed where:\n" , " a = " <> a <> "\n" , " " <> bl1 <> "\n" , " b = " <> b <> "\n" , " " <> bl2 <> "\n" ] where (bl1, bl2) = diffBlame a b printChecks (PropertyNamed True _) = [] printChecks (PropertyNamed False e) = ["Property " <> e <> " failed"] printChecks (PropertyBoolean True) = [] printChecks (PropertyBoolean False) = ["Property failed"] printChecks (PropertyFail _ e) = ["Property failed: " <> e] printChecks (PropertyAnd True _ _) = [] printChecks (PropertyAnd False a1 a2) = [ "Property `cond1 && cond2' failed where:\n" , " cond1 = " <> h1 <> "\n" ] <> ((<>) " " <$> hs1) <> [ " cond2 = " <> h2 <> "\n" ] <> ((<>) " " <$> hs2) where (h1, hs1) = f a1 (h2, hs2) = f a2 f a = case printChecks a of [] -> ("Succeed", []) (x:xs) -> (x, xs) propertyGetArgs (PropertyArg a p) = a : propertyGetArgs p propertyGetArgs (PropertyEOA _) = [] getChecks (PropertyArg _ p) = getChecks p getChecks (PropertyEOA c ) = c diffBlame :: String -> String -> (String, String) diffBlame a b = bimap fromList fromList $ go ([], []) (toList a) (toList b) where go (acc1, acc2) [] [] = (acc1, acc2) go (acc1, acc2) l1 [] = (acc1 <> blaming (length l1), acc2) go (acc1, acc2) [] l2 = (acc1 , acc2 <> blaming (length l2)) go (acc1, acc2) (x:xs) (y:ys) | x == y = go (acc1 <> " ", acc2 <> " ") xs ys | otherwise = go (acc1 <> "^", acc2 <> "^") xs ys blaming n = replicate n '^' foundation-0.0.23/Foundation/Check/Arbitrary.hs0000644000000000000000000001530713415353646017566 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} module Foundation.Check.Arbitrary ( Arbitrary(..) , frequency , oneof , elements , between ) where import Basement.Imports import Foundation.Primitive import Basement.Nat import Basement.Cast (cast) import Basement.IntegralConv import Basement.Bounded import Basement.Types.OffsetSize import qualified Basement.Types.Char7 as Char7 import Basement.Types.Word128 (Word128(..)) import Basement.Types.Word256 (Word256(..)) #if __GLASGOW_HASKELL__ >= 710 import qualified Basement.Sized.List as ListN #endif import Foundation.Check.Gen import Foundation.Random import Foundation.Bits import Foundation.Collection import Foundation.Numerical import Control.Monad (replicateM) -- | How to generate an arbitrary value for 'a' class Arbitrary a where arbitrary :: Gen a instance Arbitrary Integer where arbitrary = arbitraryInteger instance Arbitrary Natural where arbitrary = arbitraryNatural instance (NatWithinBound Word64 n, KnownNat n) => Arbitrary (Zn64 n) where arbitrary = zn64 <$> arbitrary instance KnownNat n => Arbitrary (Zn n) where arbitrary = zn <$> arbitraryNatural -- prim types instance Arbitrary Int where arbitrary = int64ToInt <$> arbitraryInt64 instance Arbitrary Word where arbitrary = word64ToWord <$> arbitraryWord64 instance Arbitrary Word256 where arbitrary = Word256 <$> arbitraryWord64 <*> arbitraryWord64 <*> arbitraryWord64 <*> arbitraryWord64 instance Arbitrary Word128 where arbitrary = Word128 <$> arbitraryWord64 <*> arbitraryWord64 instance Arbitrary Word64 where arbitrary = arbitraryWord64 instance Arbitrary Word32 where arbitrary = integralDownsize <$> arbitraryWord64 instance Arbitrary Word16 where arbitrary = integralDownsize <$> arbitraryWord64 instance Arbitrary Word8 where arbitrary = integralDownsize <$> arbitraryWord64 instance Arbitrary Int64 where arbitrary = arbitraryInt64 instance Arbitrary Int32 where arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Int16 where arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Int8 where arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Char where arbitrary = arbitraryChar instance Arbitrary Char7 where arbitrary = Char7.fromByteMask . integralDownsize <$> arbitraryWord64 instance Arbitrary (CountOf ty) where arbitrary = CountOf <$> arbitrary instance Arbitrary Bool where arbitrary = flip testBit 0 <$> arbitraryWord64 instance Arbitrary String where arbitrary = genWithParams $ \params -> fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (cast i) arbitrary) instance Arbitrary AsciiString where arbitrary = genWithParams $ \params -> fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (cast i) arbitrary) instance Arbitrary Float where arbitrary = arbitraryF32 instance Arbitrary Double where arbitrary = arbitraryF64 instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = frequency $ nonEmpty_ [ (1, pure Nothing), (4, Just <$> arbitrary) ] instance (Arbitrary l, Arbitrary r) => Arbitrary (Either l r) where arbitrary = oneof $ nonEmpty_ [ Left <$> arbitrary, Right <$> arbitrary ] 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 instance Arbitrary a => Arbitrary [a] where arbitrary = genWithParams $ \params -> fromList <$> (genMax (genMaxSizeArray params) >>= \i -> replicateM (cast i) arbitrary) #if __GLASGOW_HASKELL__ >= 710 instance (Arbitrary a, KnownNat n, NatWithinBound Int n) => Arbitrary (ListN.ListN n a) where arbitrary = ListN.replicateM arbitrary #endif arbitraryInteger :: Gen Integer arbitraryInteger = -- TODO use the sized parameter frequency $ nonEmpty_ [ (4, integerOfSize True 2) , (4, integerOfSize False 2) , (4, integerOfSize True 4) , (4, integerOfSize False 4) , (2, integerOfSize True 8) , (2, integerOfSize False 8) , (1, integerOfSize True 16) , (1, integerOfSize False 16) ] where integerOfSize :: Bool -> Word -> Gen Integer integerOfSize toSign n = ((if toSign then negate else id) . foldl' (\x y -> x + integralUpsize y) 0 . toList) <$> (arbitraryUArrayOf n :: Gen (UArray Word8)) arbitraryNatural :: Gen Natural arbitraryNatural = integralDownsize . abs <$> arbitraryInteger arbitraryChar :: Gen Char arbitraryChar = frequency $ nonEmpty_ [ (6, wordToChar <$> genMax 128) , (1, wordToChar <$> genMax 0x10ffff) ] arbitraryWord64 :: Gen Word64 arbitraryWord64 = genWithRng getRandomWord64 arbitraryInt64 :: Gen Int64 arbitraryInt64 = cast <$> arbitraryWord64 arbitraryF64 :: Gen Double arbitraryF64 = genWithRng getRandomF64 arbitraryF32 :: Gen Float arbitraryF32 = genWithRng getRandomF32 arbitraryUArrayOf :: (PrimType ty, Arbitrary ty) => Word -> Gen (UArray ty) arbitraryUArrayOf size = between (0, size) >>= \sz -> fromList <$> replicateM (cast sz) arbitrary -- | Call one of the generator weighted frequency :: NonEmpty [(Word, Gen a)] -> Gen a frequency (getNonEmpty -> l) = between (0, sum) >>= pickOne l where sum :: Word !sum = foldl' (+) 0 $ fmap fst l pickOne ((k,x):xs) n | n <= k = x | otherwise = pickOne xs (n-k) pickOne _ _ = error "frequency" oneof :: NonEmpty [Gen a] -> Gen a oneof ne = frequency (nonEmptyFmap (\x -> (1, x)) ne) elements :: NonEmpty [a] -> Gen a elements l = frequency (nonEmptyFmap (\x -> (1, pure x)) l) between :: (Word, Word) -> Gen Word between (x,y) | range == 0 = pure x | otherwise = (+) x <$> genMax range where range = y - x genMax :: Word -> Gen Word genMax m = flip mod m <$> arbitrary foundation-0.0.23/Foundation/Check/Property.hs0000644000000000000000000001040313415353646017443 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Check.Property ( Property(..) , PropertyTestArg(..) , IsProperty , PropertyCheck(..) , property , checkHasSucceed , checkHasFailed -- * Properties , forAll , (===) , propertyCompare , propertyCompareWith , propertyAnd , propertyFail ) where import Basement.Imports hiding (Typeable) import Data.Proxy (Proxy(..)) import Basement.Compat.Typeable import Foundation.Check.Gen import Foundation.Check.Arbitrary import Data.Typeable type PropertyTestResult = Bool -- | The type of check this test did for a property data PropertyCheck = PropertyBoolean PropertyTestResult | PropertyNamed PropertyTestResult String | PropertyBinaryOp PropertyTestResult String String String | PropertyAnd PropertyTestResult PropertyCheck PropertyCheck | PropertyFail PropertyTestResult String checkHasSucceed :: PropertyCheck -> PropertyTestResult checkHasSucceed (PropertyBoolean b) = b checkHasSucceed (PropertyNamed b _) = b checkHasSucceed (PropertyBinaryOp b _ _ _) = b checkHasSucceed (PropertyAnd b _ _) = b checkHasSucceed (PropertyFail b _) = b checkHasFailed :: PropertyCheck -> PropertyTestResult checkHasFailed = not . checkHasSucceed -- | A linked-list of arguments to this test data PropertyTestArg = PropertyEOA PropertyCheck | PropertyArg String PropertyTestArg data Property = Prop { unProp :: Gen PropertyTestArg } class IsProperty p where property :: p -> Property instance IsProperty Bool where property b = Prop $ pure (PropertyEOA $ PropertyBoolean b) instance IsProperty (String, Bool) where property (name, b) = Prop $ pure (PropertyEOA $ PropertyNamed b name) instance IsProperty PropertyCheck where property check = Prop $ pure (PropertyEOA check) instance IsProperty Property where property p = p instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where property p = forAll arbitrary p -- | Running a generator for a specific type under a property forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property forAll generator tst = Prop $ do a <- generator augment a <$> unProp (property (tst a)) where augment a arg = PropertyArg (show a) arg -- | A property that check for equality of its 2 members. (===) :: (Show a, Eq a, Typeable a) => a -> a -> PropertyCheck (===) a b = let sa = pretty a Proxy sb = pretty b Proxy in PropertyBinaryOp (a == b) "==" sa sb infix 4 === pretty :: (Show a, Typeable a) => a -> Proxy a -> String pretty a pa = show a <> " :: " <> show (typeRep pa) -- | A property that check for a specific comparaison of its 2 members. -- -- This is equivalent to `===` but with `compare` propertyCompare :: (Show a, Typeable a) => String -- ^ name of the function used for comparaison, e.g. (<) -> (a -> a -> Bool) -- ^ function used for value comparaison -> a -- ^ value left of the operator -> a -- ^ value right of the operator -> PropertyCheck propertyCompare name op = propertyCompareWith name op (flip pretty Proxy) -- | A property that check for a specific comparaison of its 2 members. -- -- This is equivalent to `===` but with `compare` and a given method to -- pretty print the values. -- propertyCompareWith :: String -- ^ name of the function used for comparaison, e.g. (<) -> (a -> a -> Bool) -- ^ function used for value comparaison -> (a -> String) -- ^ function used to pretty print the values -> a -- ^ value left of the operator -> a -- ^ value right of the operator -> PropertyCheck propertyCompareWith name op display a b = let sa = display a sb = display b in PropertyBinaryOp (a `op` b) name sa sb -- | A conjuctive property composed of 2 properties that need to pass propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck propertyAnd c1 c2 = PropertyAnd (checkHasSucceed c1 && checkHasSucceed c2) c1 c2 propertyFail :: String -> PropertyCheck propertyFail = PropertyFail False foundation-0.0.23/Foundation/Check/Config.hs0000644000000000000000000000645213415353646017035 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Foundation.Check.Config ( Config(..) , Seed , DisplayOption(..) , defaultConfig , parseArgs , configHelp ) where import Basement.Imports import Basement.IntegralConv import Foundation.String.Read import Foundation.Check.Gen type Seed = Word64 data DisplayOption = DisplayTerminalErrorOnly | DisplayGroupOnly | DisplayTerminalVerbose deriving (Eq, Ord, Enum, Bounded, Show) data Config = Config { udfSeed :: Maybe Seed -- ^ optional user specified seed , getGenParams :: !GenParams -- ^ Parameters for the generator -- -- default: -- * 32bits long numbers; -- * array of 512 elements max; -- * string of 8192 bytes max. -- , numTests :: !Word64 -- ^ the number of tests to perform on every property. -- -- default: 100 , listTests :: Bool , testNameMatch :: [String] , displayOptions :: !DisplayOption , helpRequested :: Bool } -- | create the default configuration -- -- see @Config@ for details defaultConfig :: Config defaultConfig = Config { udfSeed = Nothing , getGenParams = params , numTests = 100 , listTests = False , testNameMatch = [] , displayOptions = DisplayGroupOnly , helpRequested = False } where params = GenParams { genMaxSizeIntegral = 32 -- 256 bits maximum numbers , genMaxSizeArray = 512 -- 512 elements , genMaxSizeString = 8192 -- 8K string } type ParamError = String getInteger :: String -> String -> Either ParamError Integer getInteger optionName s = maybe (Left errMsg) Right $ readIntegral s where errMsg = "argument error for " <> optionName <> " expecting a number but got : " <> s parseArgs :: [String] -> Config -> Either ParamError Config parseArgs [] cfg = Right cfg parseArgs ["--seed"] _ = Left "option `--seed' is missing a parameter" parseArgs ("--seed":x:xs) cfg = getInteger "seed" x >>= \i -> parseArgs xs $ cfg { udfSeed = Just $ integralDownsize i } parseArgs ["--tests"] _ = Left "option `--tests' is missing a parameter" parseArgs ("--tests":x:xs) cfg = getInteger "tests" x >>= \i -> parseArgs xs $ cfg { numTests = integralDownsize i } parseArgs ("--quiet":xs) cfg = parseArgs xs $ cfg { displayOptions = DisplayTerminalErrorOnly } parseArgs ("--list-tests":xs) cfg = parseArgs xs $ cfg { listTests = True } parseArgs ("--verbose":xs) cfg = parseArgs xs $ cfg { displayOptions = DisplayTerminalVerbose } parseArgs ("--help":xs) cfg = parseArgs xs $ cfg { helpRequested = True } parseArgs (x:xs) cfg = parseArgs xs $ cfg { testNameMatch = x : testNameMatch cfg } configHelp :: [String] configHelp = [ "Usage: [options] [test-name-match]\n" , "\n" , "Known options:\n" , "\n" , " --seed : a 64bit positive number to use as seed to generate arbitrary value.\n" , " --tests : the number of tests to perform for every property tests.\n" , " --quiet: print only the errors to the standard output\n" , " --verbose: print every property tests to the stand output.\n" , " --list-tests: print all test names.\n" ] foundation-0.0.23/Foundation/Check/Types.hs0000644000000000000000000000446613415353646016737 0ustar0000000000000000-- | -- Module : Foundation.Check.Types -- License : BSD-style -- Maintainer : Foundation maintainers -- -- A implementation of a test framework -- and property expression & testing -- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Check.Types ( Test(..) , testName , fqTestName , groupHasSubGroup , Check(..) , PlanState(..) , PropertyResult(..) , TestResult(..) , HasFailures ) where import Basement.Imports import Foundation.Collection import Foundation.Monad.State import Foundation.Check.Property import Foundation.Check.Gen -- | Result of a property run data PropertyResult = PropertySuccess | PropertyFailed String deriving (Show,Eq) -- | Name of a test Followed data TestResult = PropertyResult String HasTests PropertyResult | GroupResult String HasFailures HasTests [TestResult] deriving (Show) -- | number of tests and failures type HasTests = CountOf TestResult type HasFailures = CountOf TestResult data PlanState = PlanState { planRng :: Word64 -> GenRng , planValidations :: CountOf TestResult , planParams :: GenParams , planFailures :: [TestResult] } newtype Check a = Check { runCheck :: StateT PlanState IO a } deriving (Functor, Applicative, Monad) instance MonadState Check where type State Check = PlanState withState f = Check (withState f) -- | different type of tests supported 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 -- Check plan CheckPlan :: String -> Check () -> Test -- | Name of a test testName :: Test -> String testName (Unit s _) = s testName (Property s _) = s testName (Group s _) = s testName (CheckPlan s _) = s fqTestName :: [String] -> String fqTestName = intercalate "/" . reverse groupHasSubGroup :: [Test] -> Bool groupHasSubGroup [] = False groupHasSubGroup (Group{}:_) = True groupHasSubGroup (_:xs) = groupHasSubGroup xs foundation-0.0.23/Foundation/Collection/Buildable.hs0000644000000000000000000000556413415353646020574 0ustar0000000000000000-- | -- Module : Foundation.Collection.Buildable -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- -- An interface for collections that can be built incrementally. -- module Foundation.Collection.Buildable ( Buildable(..) , Builder(..) , BuildingState(..) , builderLift , build_ ) where import Basement.UArray import Basement.UArray.Mutable import qualified Basement.BoxedArray as BA import qualified Basement.String as S import Foundation.Collection.Element import Basement.Compat.Base import Basement.Monad import Basement.MutableBuilder import Basement.Compat.MonadTrans -- $setup -- >>> import Control.Monad.ST -- >>> import Basement.UArray -- >>> import Basement.Compat.Base -- >>> import Basement.OffsetSize -- | Collections that can be built chunk by chunk. -- -- Use the 'Monad' instance of 'Builder' to chain 'append' operations -- and feed it into `build`: -- -- >>> runST $ build 32 (append 'a' >> append 'b' >> append 'c') :: UArray Char -- "abc" class Buildable col where {-# MINIMAL append, build #-} -- | Mutable collection type used for incrementally writing chunks. type Mutable col :: * -> * -- | Unit of the smallest step possible in an `append` operation. -- -- A UTF-8 character can have a size between 1 and 4 bytes, so this -- should be defined as 1 byte for collections of `Char`. type Step col append :: (PrimMonad prim) => Element col -> Builder col (Mutable col) (Step col) prim err () build :: (PrimMonad prim) => Int -- ^ CountOf of a chunk -> Builder col (Mutable col) (Step col) prim err () -> prim (Either err col) builderLift :: (Buildable c, PrimMonad prim) => prim a -> Builder c (Mutable c) (Step c) prim err a builderLift f = Builder $ State $ \(i, st, e) -> do ret <- f return (ret, (i, st, e)) build_ :: (Buildable c, PrimMonad prim) => Int -- ^ CountOf of a chunk -> Builder c (Mutable c) (Step c) prim () () -> prim c build_ sizeChunksI ab = either (\() -> internalError "impossible output") id <$> build sizeChunksI ab instance PrimType ty => Buildable (UArray ty) where type Mutable (UArray ty) = MUArray ty type Step (UArray ty) = ty append = builderAppend {-# INLINE append #-} build = builderBuild {-# INLINE build #-} instance Buildable (BA.Array ty) where type Mutable (BA.Array ty) = BA.MArray ty type Step (BA.Array ty) = ty append = BA.builderAppend {-# INLINE append #-} build = BA.builderBuild {-# INLINE build #-} instance Buildable S.String where type Mutable S.String = S.MutableString type Step S.String = Word8 append = S.builderAppend {-# INLINE append #-} build = S.builderBuild {-# INLINE build #-} foundation-0.0.23/Foundation/Collection/List.hs0000644000000000000000000000332013415353646017610 0ustar0000000000000000-- | -- Module : Foundation.Collection.List -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- module Foundation.Collection.List ( wordsWhen , revTake , revDrop , revSplitAt , breakEnd , uncons , unsnoc ) where import qualified Data.List import Data.Tuple (swap) import Basement.Compat.Base import Foundation.Numerical -- | Simple helper to split a list repeatly when the predicate match wordsWhen :: (x -> Bool) -> [x] -> [[x]] wordsWhen _ [] = [[]] wordsWhen p is = loop is where loop s = let (w, s') = Data.List.break p s in case s' of [] -> [w] _:xs -> w : loop xs revTake :: Int -> [a] -> [a] revTake n l = Data.List.drop (len - n) l where len = Data.List.length l revDrop :: Int -> [a] -> [a] revDrop n l = Data.List.take (len - n) l where len = Data.List.length l revSplitAt :: Int -> [a] -> ([a],[a]) revSplitAt n l = swap $ Data.List.splitAt (len - n) l where len = Data.List.length l breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) breakEnd predicate l = let (l1,l2) = Data.List.break predicate (Data.List.reverse l) in if Data.List.null l2 then (l, []) else (Data.List.reverse l2, Data.List.reverse l1) uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing uncons (x:xs) = Just (x,xs) unsnoc :: [a] -> Maybe ([a], a) unsnoc [] = Nothing unsnoc [x] = Just ([], x) unsnoc [x,y] = Just ([x], y) unsnoc (x:xs@(_:_)) = Just $ loop [x] xs where loop acc [y] = (Data.List.reverse acc, y) loop acc (y:ys) = loop (y:acc) ys loop _ _ = error "impossible" foundation-0.0.23/Foundation/Collection/Element.hs0000644000000000000000000000211213415353646020264 0ustar0000000000000000-- | -- Module : Foundation.Array.Element -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- {-# LANGUAGE CPP #-} module Foundation.Collection.Element ( Element ) where import Basement.Compat.Base import Basement.Block (Block) import Basement.UArray (UArray) import Basement.BoxedArray (Array) import Basement.String (String) import Basement.Types.AsciiString (AsciiString) import Basement.Types.Char7 (Char7) import Basement.NonEmpty #if MIN_VERSION_base(4,9,0) import Basement.Sized.Block (BlockN) import Basement.Sized.List (ListN) #endif -- | Element type of a collection type family Element container type instance Element [a] = a type instance Element (Block ty) = ty type instance Element (UArray ty) = ty type instance Element (Array ty) = ty type instance Element String = Char type instance Element AsciiString = Char7 type instance Element (NonEmpty a) = Element a #if MIN_VERSION_base(4,9,0) type instance Element (BlockN n ty) = ty type instance Element (ListN n a) = a #endif foundation-0.0.23/Foundation/Collection/InnerFunctor.hs0000644000000000000000000000140213415353646021310 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} module Foundation.Collection.InnerFunctor ( InnerFunctor(..) ) where import Basement.Compat.Base import Foundation.Collection.Element import qualified Basement.String as S import qualified Basement.UArray as UV import Basement.BoxedArray (Array) -- | 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) => (Element c -> Element c) -> c -> c imap = fmap instance InnerFunctor [a] instance UV.PrimType ty => InnerFunctor (UV.UArray ty) where imap = UV.map instance InnerFunctor (Array ty) instance InnerFunctor S.String where imap = S.charMap foundation-0.0.23/Foundation/Collection/Collection.hs0000644000000000000000000001210013415353646020764 0ustar0000000000000000-- | -- Module : Foundation.Collection.Collection -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- -- Provide basic collection information. It's difficult to provide a -- unified interface to all sorts of collection, but when creating this -- API we had the following types in mind: -- -- * List (e.g [a]) -- * Array -- * Collection of collection (e.g. deque) -- * Hashtables, Trees -- -- an API to rules them all, and in the darkness bind them. -- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Collection.Collection ( Collection(..) -- * NonEmpty Property , NonEmpty , getNonEmpty , nonEmpty , nonEmpty_ , nonEmptyFmap , and , or ) where import Basement.Compat.Base hiding (and) import Basement.Types.OffsetSize import Basement.Types.AsciiString import Basement.Exception (NonEmptyCollectionIsEmpty(..)) import Foundation.Collection.Element import Basement.NonEmpty import qualified Data.List import qualified Basement.Block as BLK import qualified Basement.UArray as UV import qualified Basement.BoxedArray as BA import qualified Basement.String as S -- | Smart constructor to create a NonEmpty collection -- -- If the collection is empty, then Nothing is returned -- Otherwise, the collection is wrapped in the NonEmpty property nonEmpty :: Collection c => c -> Maybe (NonEmpty c) nonEmpty c | null c = Nothing | otherwise = Just (NonEmpty c) -- | same as 'nonEmpty', but assume that the collection is non empty, -- and return an asynchronous error if it is. nonEmpty_ :: Collection c => c -> NonEmpty c nonEmpty_ c | null c = throw NonEmptyCollectionIsEmpty | otherwise = NonEmpty c nonEmptyFmap :: Functor f => (a -> b) -> NonEmpty (f a) -> NonEmpty (f b) nonEmptyFmap f (NonEmpty l) = NonEmpty (fmap f l) -- | A set of methods for ordered colection class (IsList c, Item c ~ Element c) => Collection c where {-# MINIMAL null, length, (elem | notElem), minimum, maximum, all, any #-} -- | Check if a collection is empty null :: c -> Bool -- | Length of a collection (number of Element c) length :: c -> CountOf (Element c) -- | Check if a collection contains a specific element -- -- This is the inverse of `notElem`. elem :: forall a . (Eq a, a ~ Element c) => Element c -> c -> Bool elem e col = not $ e `notElem` col -- | Check if a collection does *not* contain a specific element -- -- This is the inverse of `elem`. notElem :: forall a . (Eq a, a ~ Element c) => Element c -> c -> Bool notElem e col = not $ e `elem` col -- | Get the maximum element of a collection maximum :: forall a . (Ord a, a ~ Element c) => NonEmpty c -> Element c -- | Get the minimum element of a collection minimum :: forall a . (Ord a, a ~ Element c) => NonEmpty c -> Element c -- | Determine is any elements of the collection satisfy the predicate any :: (Element c -> Bool) -> c -> Bool -- | Determine is all elements of the collection satisfy the predicate all :: (Element c -> Bool) -> c -> Bool instance Collection [a] where null = Data.List.null length = CountOf . Data.List.length elem = Data.List.elem notElem = Data.List.notElem minimum = Data.List.minimum . getNonEmpty maximum = Data.List.maximum . getNonEmpty any = Data.List.any all = Data.List.all instance UV.PrimType ty => Collection (BLK.Block ty) where null = (==) 0 . BLK.length length = BLK.length elem = BLK.elem minimum = BLK.foldl1' min maximum = BLK.foldl1' max all = BLK.all any = BLK.any instance UV.PrimType ty => Collection (UV.UArray ty) where null = UV.null length = UV.length elem = UV.elem minimum = UV.foldl1' min maximum = UV.foldl1' max all = UV.all any = UV.any instance Collection (BA.Array ty) where null = BA.null length = BA.length elem = BA.elem minimum = BA.foldl1' min maximum = BA.foldl1' max all = BA.all any = BA.any deriving instance Collection AsciiString instance Collection S.String where null = S.null length = S.length elem = S.elem minimum = Data.List.minimum . toList . getNonEmpty -- TODO faster implementation maximum = Data.List.maximum . toList . getNonEmpty -- TODO faster implementation all = S.all any = S.any instance Collection c => Collection (NonEmpty c) where null _ = False length = length . getNonEmpty elem e = elem e . getNonEmpty maximum = maximum . getNonEmpty minimum = minimum . getNonEmpty all p = all p . getNonEmpty any p = any p . getNonEmpty -- | Return True if all the elements in the collection are True and :: (Collection col, Element col ~ Bool) => col -> Bool and = all (== True) -- | Return True if at least one element in the collection is True or :: (Collection col, Element col ~ Bool) => col -> Bool or = any (== True) foundation-0.0.23/Foundation/Collection/Copy.hs0000644000000000000000000000217213415353646017613 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} module Foundation.Collection.Copy ( Copy(..) ) where import GHC.ST (runST) import Basement.Compat.Base ((>>=)) import Basement.Nat import Basement.Types.OffsetSize import qualified Basement.Block as BLK import qualified Basement.UArray as UA import qualified Basement.BoxedArray as BA import qualified Basement.String as S #if MIN_VERSION_base(4,9,0) import qualified Basement.Sized.Block as BLKN import qualified Basement.Sized.List as LN #endif class Copy a where copy :: a -> a instance Copy [ty] where copy a = a instance UA.PrimType ty => Copy (BLK.Block ty) where copy blk = runST (BLK.thaw blk >>= BLK.unsafeFreeze) instance UA.PrimType ty => Copy (UA.UArray ty) where copy = UA.copy instance Copy (BA.Array ty) where copy = BA.copy instance Copy S.String where copy = S.copy #if MIN_VERSION_base(4,9,0) instance Copy (LN.ListN n ty) where copy a = a instance (Countable ty n, UA.PrimType ty, KnownNat n) => Copy (BLKN.BlockN n ty) where copy blk = runST (BLKN.thaw blk >>= BLKN.freeze) #endif foundation-0.0.23/Foundation/Collection/Sequential.hs0000644000000000000000000002660213415353646021017 0ustar0000000000000000-- | -- Module : Foundation.Collection.Sequential -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Different collections (list, vector, string, ..) unified under 1 API. -- an API to rules them all, and in the darkness bind them. -- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} module Foundation.Collection.Sequential ( Sequential(..) ) where import Basement.Compat.Base import Basement.Numerical.Subtractive import Basement.Types.OffsetSize import Basement.Types.AsciiString (AsciiString(..)) import Foundation.Collection.Element import Foundation.Collection.Collection import qualified Foundation.Collection.List as ListExtra import qualified Data.List import qualified Basement.UArray as UV import qualified Basement.Block as BLK import qualified Basement.BoxedArray as BA import qualified Basement.String as S -- | A set of methods for ordered colection class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where {-# MINIMAL ((take, drop) | splitAt) , ((revTake, revDrop) | revSplitAt) , splitOn , (break | span) , (breakEnd | spanEnd) , intersperse , filter, reverse , uncons, unsnoc, snoc, cons , find, sortBy, singleton , replicate #-} -- | Take the first @n elements of a collection take :: CountOf (Element c) -> c -> c take n = fst . splitAt n -- | Take the last @n elements of a collection revTake :: CountOf (Element c) -> c -> c revTake n = fst . revSplitAt n -- | Drop the first @n elements of a collection drop :: CountOf (Element c) -> c -> c drop n = snd . splitAt n -- | Drop the last @n elements of a collection revDrop :: CountOf (Element c) -> c -> c revDrop n = snd . revSplitAt n -- | Split the collection at the @n'th elements splitAt :: CountOf (Element c) -> c -> (c,c) splitAt n c = (take n c, drop n c) -- | Split the collection at the @n'th elements from the end revSplitAt :: CountOf (Element c) -> c -> (c,c) revSplitAt n c = (revTake n c, revDrop n c) -- | Split on a specific elements returning a list of colletion splitOn :: (Element c -> Bool) -> c -> [c] -- | Split a collection when the predicate return true break :: (Element c -> Bool) -> c -> (c,c) break predicate = span (not . predicate) -- | Split a collection when the predicate return true starting from the end of the collection breakEnd :: (Element c -> Bool) -> c -> (c,c) breakEnd predicate = spanEnd (not . predicate) -- | Split a collection at the given element breakElem :: Eq (Element c) => Element c -> c -> (c,c) breakElem c = break (== c) -- | Return the longest prefix in the collection that satisfy the predicate takeWhile :: (Element c -> Bool) -> c -> c takeWhile predicate = fst . span predicate -- | Return the longest prefix in the collection that satisfy the predicate dropWhile :: (Element c -> Bool) -> c -> c dropWhile predicate = snd . span predicate -- | The 'intersperse' function takes an element and a list and -- \`intersperses\' that element between the elements of the list. -- For example, -- -- > intersperse ',' "abcde" == "a,b,c,d,e" intersperse :: Element c -> c -> c -- | 'intercalate' @xs xss@ is equivalent to @('mconcat' ('intersperse' xs xss))@. -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the -- result. intercalate :: Monoid (Item c) => Element c -> c -> Element c intercalate xs xss = mconcatCollection (intersperse xs xss) -- | Split a collection while the predicate return true span :: (Element c -> Bool) -> c -> (c,c) span predicate = break (not . predicate) -- | Split a collection while the predicate return true starting from the end of the collection spanEnd :: (Element c -> Bool) -> c -> (c,c) spanEnd predicate = breakEnd (not . predicate) -- | Filter all the elements that satisfy the predicate filter :: (Element c -> Bool) -> c -> c -- | Partition the elements that satisfy the predicate and those that don't partition :: (Element c -> Bool) -> c -> (c,c) partition predicate c = (filter predicate c, filter (not . predicate) c) -- | Reverse a collection reverse :: c -> c -- | Decompose a collection into its first element and the remaining collection. -- If the collection is empty, returns Nothing. uncons :: c -> Maybe (Element c, c) -- | Decompose a collection into a collection without its last element, and the last element -- If the collection is empty, returns Nothing. unsnoc :: c -> Maybe (c, Element c) -- | Prepend an element to an ordered collection snoc :: c -> Element c -> c -- | Append an element to an ordered collection cons :: Element c -> c -> c -- | Find an element in an ordered collection find :: (Element c -> Bool) -> c -> Maybe (Element c) -- | Sort an ordered collection using the specified order function sortBy :: (Element c -> Element c -> Ordering) -> c -> c -- | Create a collection with a single element singleton :: Element c -> c -- | get the first element of a non-empty collection head :: NonEmpty c -> Element c head nel = maybe (error "head") fst $ uncons (getNonEmpty nel) -- | get the last element of a non-empty collection last :: NonEmpty c -> Element c last nel = maybe (error "last") snd $ unsnoc (getNonEmpty nel) -- | Extract the elements after the first element of a non-empty collection. tail :: NonEmpty c -> c tail nel = maybe (error "tail") snd $ uncons (getNonEmpty nel) -- | Extract the elements before the last element of a non-empty collection. init :: NonEmpty c -> c init nel = maybe (error "init") fst $ unsnoc (getNonEmpty nel) -- | Create a collection where the element in parameter is repeated N time replicate :: CountOf (Element c) -> Element c -> c -- | Takes two collections and returns True iff the first collection is a prefix of the second. isPrefixOf :: Eq (Element c) => c -> c -> Bool default isPrefixOf :: Eq c => c -> c -> Bool isPrefixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == take len1 c2 where len1 = length c1 len2 = length c2 -- | Takes two collections and returns True iff the first collection is a suffix of the second. isSuffixOf :: Eq (Element c) => c -> c -> Bool default isSuffixOf :: Eq c => c -> c -> Bool isSuffixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == revTake len1 c2 where len1 = length c1 len2 = length c2 -- | Takes two collections and returns True iff the first collection is an infix of the second. isInfixOf :: Eq (Element c) => c -> c -> Bool default isInfixOf :: Eq c => c -> c -> Bool isInfixOf c1 c2 = loop (len2 - len1) c2 where len1 = length c1 len2 = length c2 loop (Just cnt) c2' = c1 == take len1 c2' || loop (cnt - 1) (drop 1 c2') loop Nothing _ = False -- | Try to strip a prefix from a collection stripPrefix :: Eq (Element c) => c -> c -> Maybe c stripPrefix pre s | isPrefixOf pre s = Just $ drop (length pre) s | otherwise = Nothing -- | Try to strip a suffix from a collection stripSuffix :: Eq (Element c) => c -> c -> Maybe c stripSuffix suf s | isSuffixOf suf s = Just $ revDrop (length suf) s | otherwise = Nothing -- Temporary utility functions mconcatCollection :: (Monoid (Item c), Sequential c) => c -> Element c mconcatCollection c = mconcat (toList c) instance Sequential [a] where take (CountOf n) = Data.List.take n drop (CountOf n) = Data.List.drop n revTake (CountOf n) = ListExtra.revTake n revDrop (CountOf n) = ListExtra.revDrop n splitAt (CountOf n) = Data.List.splitAt n revSplitAt (CountOf n) = ListExtra.revSplitAt n splitOn = ListExtra.wordsWhen break = Data.List.break breakEnd = ListExtra.breakEnd intersperse = Data.List.intersperse span = Data.List.span dropWhile = Data.List.dropWhile takeWhile = Data.List.takeWhile filter = Data.List.filter partition = Data.List.partition reverse = Data.List.reverse uncons = ListExtra.uncons unsnoc = ListExtra.unsnoc snoc c e = c `mappend` [e] cons e c = e : c find = Data.List.find sortBy = Data.List.sortBy singleton = (:[]) replicate (CountOf i) = Data.List.replicate i isPrefixOf = Data.List.isPrefixOf isSuffixOf = Data.List.isSuffixOf instance UV.PrimType ty => Sequential (BLK.Block ty) where splitAt n = BLK.splitAt n revSplitAt n = BLK.revSplitAt n splitOn = BLK.splitOn break = BLK.break breakEnd = BLK.breakEnd intersperse = BLK.intersperse span = BLK.span filter = BLK.filter reverse = BLK.reverse uncons = BLK.uncons unsnoc = BLK.unsnoc snoc = BLK.snoc cons = BLK.cons find = BLK.find sortBy = BLK.sortBy singleton = BLK.singleton replicate = BLK.replicate instance UV.PrimType ty => Sequential (UV.UArray ty) where take = UV.take revTake = UV.revTake drop = UV.drop revDrop = UV.revDrop splitAt = UV.splitAt revSplitAt = UV.revSplitAt splitOn = UV.splitOn break = UV.break breakEnd = UV.breakEnd breakElem = UV.breakElem intersperse = UV.intersperse span = UV.span filter = UV.filter reverse = UV.reverse uncons = UV.uncons unsnoc = UV.unsnoc snoc = UV.snoc cons = UV.cons find = UV.find sortBy = UV.sortBy singleton = fromList . (:[]) replicate = UV.replicate isPrefixOf = UV.isPrefixOf isSuffixOf = UV.isSuffixOf instance Sequential (BA.Array ty) where take = BA.take drop = BA.drop splitAt = BA.splitAt revTake = BA.revTake revDrop = BA.revDrop revSplitAt = BA.revSplitAt splitOn = BA.splitOn break = BA.break breakEnd = BA.breakEnd intersperse = BA.intersperse span = BA.span reverse = BA.reverse filter = BA.filter unsnoc = BA.unsnoc uncons = BA.uncons snoc = BA.snoc cons = BA.cons find = BA.find sortBy = BA.sortBy singleton = BA.singleton replicate = BA.replicate isSuffixOf = BA.isSuffixOf isPrefixOf = BA.isPrefixOf instance Sequential S.String where take = S.take drop = S.drop splitAt = S.splitAt revTake = S.revTake revDrop = S.revDrop revSplitAt = S.revSplitAt splitOn = S.splitOn break = S.break breakEnd = S.breakEnd breakElem = S.breakElem intersperse = S.intersperse span = S.span filter = S.filter reverse = S.reverse unsnoc = S.unsnoc uncons = S.uncons snoc = S.snoc cons = S.cons find = S.find sortBy = S.sortBy singleton = S.singleton replicate = S.replicate isSuffixOf = S.isSuffixOf isPrefixOf = S.isPrefixOf isInfixOf = S.isInfixOf stripPrefix = S.stripPrefix stripSuffix = S.stripSuffix deriving instance Sequential AsciiString foundation-0.0.23/Foundation/Collection/Keyed.hs0000644000000000000000000000121313415353646017735 0ustar0000000000000000-- | -- Module : Foundation.Array.Keyed -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- {-# LANGUAGE FlexibleInstances #-} module Foundation.Collection.Keyed ( KeyedCollection(..) ) where import Basement.Compat.Base import qualified Data.List -- | Collection of things that can be looked up by Key class KeyedCollection c where type Key c type Value c lookup :: Key c -> c -> Maybe (Value c) instance Eq k => KeyedCollection [(k, v)] where type Key [(k,v)] = k type Value [(k,v)] = v lookup = Data.List.lookup foundation-0.0.23/Foundation/Collection/Indexed.hs0000644000000000000000000000751613415353646020270 0ustar0000000000000000-- | -- Module : Foundation.Array.Indexed -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,9,0) {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} #endif module Foundation.Collection.Indexed ( IndexedCollection(..) ) where import Basement.Compat.Base import Basement.Numerical.Additive ((+)) import Basement.Types.OffsetSize import Foundation.Collection.Element import qualified Data.List import qualified Basement.Block as BLK import qualified Basement.UArray as UV import qualified Basement.BoxedArray as BA import qualified Basement.Exception as A import qualified Basement.String as S #if MIN_VERSION_base(4,9,0) import qualified Basement.Sized.Block as BLKN import qualified Basement.Sized.List as LN import Basement.Nat #endif -- | Collection of elements that can indexed by int class IndexedCollection c where (!) :: c -> Offset (Element c) -> Maybe (Element c) findIndex :: (Element c -> Bool) -> c -> Maybe (Offset (Element c)) instance IndexedCollection [a] where (!) l (Offset n) | n < 0 = Nothing | otherwise = case Data.List.drop n l of [] -> Nothing x:_ -> Just x findIndex predicate = fmap Offset . Data.List.findIndex predicate instance UV.PrimType ty => IndexedCollection (BLK.Block ty) where (!) l n | A.isOutOfBound n (BLK.length l) = Nothing | otherwise = Just $ BLK.index l n findIndex predicate c = loop 0 where !len = BLK.length c loop i | i .==# len = Nothing | predicate (BLK.unsafeIndex c i) = Just i | otherwise = loop (i + 1) instance UV.PrimType ty => IndexedCollection (UV.UArray ty) where (!) l n | A.isOutOfBound n (UV.length l) = Nothing | otherwise = Just $ UV.index l n findIndex predicate c = loop 0 where !len = UV.length c loop i | i .==# len = Nothing | predicate (UV.unsafeIndex c i) = Just i | otherwise = Nothing instance IndexedCollection (BA.Array ty) where (!) l n | A.isOutOfBound n (BA.length l) = Nothing | otherwise = Just $ BA.index l n findIndex predicate c = loop 0 where !len = BA.length c loop i | i .==# len = Nothing | otherwise = if predicate (BA.unsafeIndex c i) then Just i else Nothing instance IndexedCollection S.String where (!) = S.index findIndex = S.findIndex #if MIN_VERSION_base(4,9,0) instance (NatWithinBound Int n, KnownNat n) => IndexedCollection (LN.ListN n a) where (!) c off | A.isOutOfBound off (LN.length c) = Nothing | otherwise = Just $ LN.index c off findIndex predicate c = loop 0 where !len = LN.length c loop i | i .==# len = Nothing | predicate (LN.index c i) = Just i | otherwise = loop (i + 1) instance (NatWithinBound (CountOf ty) n, KnownNat n, UV.PrimType ty) => IndexedCollection (BLKN.BlockN n ty) where (!) c off | A.isOutOfBound off (BLKN.length c) = Nothing | otherwise = Just $ BLKN.index c off findIndex predicate c = loop 0 where !len = BLKN.length c loop i | i .==# len = Nothing | predicate (BLKN.index c i) = Just i | otherwise = loop (i + 1) #endif foundation-0.0.23/Foundation/Collection/Foldable.hs0000644000000000000000000001007213415353646020407 0ustar0000000000000000-- | -- Module : Basement.Foldable -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- A mono-morphic re-thinking of the Foldable class -- {-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,9,0) {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} #endif module Foundation.Collection.Foldable ( Foldable(..) , Fold1able(..) ) where import Basement.Compat.Base import Foundation.Collection.Element import Basement.NonEmpty import Basement.Nat import qualified Data.List import qualified Basement.UArray as UV import qualified Basement.Block as BLK import qualified Basement.BoxedArray as BA #if MIN_VERSION_base(4,9,0) import qualified Basement.Sized.List as LN import qualified Basement.Sized.Block as BLKN #endif -- | Give the ability to fold a collection on itself class Foldable collection where -- | Left-associative fold of a structure. -- -- In the case of lists, foldl, when applied to a binary operator, a starting value (typically the left-identity of the operator), and a list, reduces the list using the binary operator, from left to right: -- -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn -- Note that to produce the outermost application of the operator the entire input list must be traversed. This means that foldl' will diverge if given an infinite list. -- -- Note that Foundation only provides `foldl'`, a strict version of `foldl` because -- the lazy version is seldom useful. -- | Left-associative fold of a structure with strict application of the operator. foldl' :: (a -> Element collection -> a) -> a -> collection -> a -- | Right-associative fold of a structure. -- -- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...) foldr :: (Element collection -> a -> a) -> a -> collection -> a -- | Right-associative fold of a structure, but with strict application of the operator. foldr' :: (Element collection -> a -> a) -> a -> collection -> a foldr' f z0 xs = foldl' f' id xs z0 where f' k x z = k $! f x z -- | Fold1's. Like folds, but they assume to operate on a NonEmpty collection. class Foldable f => Fold1able f where -- | Left associative strict fold. foldl1' :: (Element f -> Element f -> Element f) -> NonEmpty f -> Element f -- | Right associative lazy fold. foldr1 :: (Element f -> Element f -> Element f) -> NonEmpty f -> Element f -- | Right associative strict fold. --foldr1' :: (Element f -> Element f -> Element f) -> NonEmpty f -> Element f --foldr1' f xs = foldl f' id . getNonEmpty -- where f' k x z = k $! f x z ---------------------------- -- Foldable instances ---------------------------- instance Foldable [a] where foldr = Data.List.foldr foldl' = Data.List.foldl' instance UV.PrimType ty => Foldable (UV.UArray ty) where foldr = UV.foldr foldl' = UV.foldl' instance Foldable (BA.Array ty) where foldr = BA.foldr foldl' = BA.foldl' instance UV.PrimType ty => Foldable (BLK.Block ty) where foldr = BLK.foldr foldl' = BLK.foldl' #if MIN_VERSION_base(4,9,0) instance Foldable (LN.ListN n a) where foldr = LN.foldr foldl' = LN.foldl' instance UV.PrimType ty => Foldable (BLKN.BlockN n ty) where foldr = BLKN.foldr foldl' = BLKN.foldl' #endif ---------------------------- -- Fold1able instances ---------------------------- instance Fold1able [a] where foldr1 f = Data.List.foldr1 f . getNonEmpty foldl1' f = Data.List.foldl1' f . getNonEmpty instance UV.PrimType ty => Fold1able (UV.UArray ty) where foldr1 = UV.foldr1 foldl1' = UV.foldl1' instance Fold1able (BA.Array ty) where foldr1 = BA.foldr1 foldl1' = BA.foldl1' instance UV.PrimType ty => Fold1able (BLK.Block ty) where foldr1 = BLK.foldr1 foldl1' = BLK.foldl1' #if MIN_VERSION_base(4,9,0) instance (1 <= n) => Fold1able (LN.ListN n a) where foldr1 f = LN.foldr1 f . getNonEmpty foldl1' f = LN.foldl1' f . getNonEmpty #endif foundation-0.0.23/Foundation/Collection/Mutable.hs0000644000000000000000000000623713415353646020300 0ustar0000000000000000-- | -- Module : Foundation.Array.Mutable -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- module Foundation.Collection.Mutable ( MutableCollection(..) ) where import Basement.Monad import Basement.Types.OffsetSize import qualified Basement.Block as BLK import qualified Basement.Block.Mutable as BLK import qualified Basement.UArray.Mutable as MUV import qualified Basement.UArray as UV import qualified Basement.BoxedArray as BA -- | Collection of things that can be made mutable, modified and then freezed into an MutableFreezed collection class MutableCollection c where -- unfortunately: cannot set mutUnsafeWrite to default to mutWrite .. same for read.. {-# MINIMAL thaw, freeze, mutNew, mutWrite, mutRead, mutUnsafeWrite, mutUnsafeRead #-} type MutableFreezed c type MutableKey c type MutableValue c unsafeThaw :: PrimMonad prim => MutableFreezed c -> prim (c (PrimState prim)) unsafeThaw = thaw unsafeFreeze :: PrimMonad prim => c (PrimState prim) -> prim (MutableFreezed c) unsafeFreeze = freeze thaw :: PrimMonad prim => MutableFreezed c -> prim (c (PrimState prim)) freeze :: PrimMonad prim => c (PrimState prim) -> prim (MutableFreezed c) mutNew :: PrimMonad prim => CountOf (MutableValue c) -> prim (c (PrimState prim)) mutUnsafeWrite :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> MutableValue c -> prim () mutWrite :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> MutableValue c -> prim () mutUnsafeRead :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> prim (MutableValue c) mutRead :: PrimMonad prim => c (PrimState prim) -> MutableKey c -> prim (MutableValue c) instance UV.PrimType ty => MutableCollection (MUV.MUArray ty) where type MutableFreezed (MUV.MUArray ty) = UV.UArray ty type MutableKey (MUV.MUArray ty) = Offset ty type MutableValue (MUV.MUArray ty) = ty thaw = UV.thaw freeze = UV.freeze unsafeThaw = UV.unsafeThaw unsafeFreeze = UV.unsafeFreeze mutNew = MUV.new mutUnsafeWrite = MUV.unsafeWrite mutUnsafeRead = MUV.unsafeRead mutWrite = MUV.write mutRead = MUV.read instance UV.PrimType ty => MutableCollection (BLK.MutableBlock ty) where type MutableFreezed (BLK.MutableBlock ty) = BLK.Block ty type MutableKey (BLK.MutableBlock ty) = Offset ty type MutableValue (BLK.MutableBlock ty) = ty thaw = BLK.thaw freeze = BLK.freeze unsafeThaw = BLK.unsafeThaw unsafeFreeze = BLK.unsafeFreeze mutNew = BLK.new mutUnsafeWrite = BLK.unsafeWrite mutUnsafeRead = BLK.unsafeRead mutWrite = BLK.write mutRead = BLK.read instance MutableCollection (BA.MArray ty) where type MutableFreezed (BA.MArray ty) = BA.Array ty type MutableKey (BA.MArray ty) = Offset ty type MutableValue (BA.MArray ty) = ty thaw = BA.thaw freeze = BA.freeze unsafeThaw = BA.unsafeThaw unsafeFreeze = BA.unsafeFreeze mutNew = BA.new mutUnsafeWrite = BA.unsafeWrite mutUnsafeRead = BA.unsafeRead mutWrite = BA.write mutRead = BA.read foundation-0.0.23/Foundation/Collection/Zippable.hs0000644000000000000000000003157213415353646020455 0ustar0000000000000000-- | -- Module : Foundation.Collection.Zippable -- License : BSD-style -- Maintainer : foundation -- Stability : experimental -- Portability : portable -- -- Common functions (e. g. 'zip', 'zipWith') that are useful for combining -- multiple collections. -- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Collection.Zippable ( BoxedZippable(..) , Zippable(..) ) where import qualified Basement.UArray as UV import qualified Basement.BoxedArray as BA import qualified Basement.String as S import Foundation.Collection.Element import Foundation.Collection.Sequential import Basement.Compat.Base import Basement.Types.AsciiString(AsciiString(..)) import qualified Prelude import GHC.ST class Sequential col => Zippable col where -- | 'zipWith' generalises 'zip' by zipping with the function given as the -- first argument, instead of a tupling function. For example, @'zipWith' (+)@ -- is applied to two collections to produce the collection of corresponding -- sums. zipWith :: (Sequential a, Sequential b) => (Element a -> Element b -> Element col) -> a -> b -> col zipWith f a b = go f (toList a, toList b) where go f' = maybe mempty (\(x, xs) -> uncurry2 f' x `cons` go f' xs) . uncons2 -- | Like 'zipWith', but works with 3 collections. zipWith3 :: (Sequential a, Sequential b, Sequential c) => (Element a -> Element b -> Element c -> Element col) -> a -> b -> c -> col zipWith3 f a b c = go f (toList a, toList b, toList c) where go f' = maybe mempty (\(x, xs) -> uncurry3 f' x `cons` go f' xs) . uncons3 -- | Like 'zipWith', but works with 4 collections. zipWith4 :: (Sequential a, Sequential b, Sequential c, Sequential d) => (Element a -> Element b -> Element c -> Element d -> Element col) -> a -> b -> c -> d -> col zipWith4 fn a b c d = go fn (toList a, toList b, toList c, toList d) where go f' = maybe mempty (\(x, xs) -> uncurry4 f' x `cons` go f' xs) . uncons4 -- | Like 'zipWith', but works with 5 collections. zipWith5 :: (Sequential a, Sequential b, Sequential c, Sequential d, Sequential e) => (Element a -> Element b -> Element c -> Element d -> Element e -> Element col) -> a -> b -> c -> d -> e -> col zipWith5 fn a b c d e = go fn (toList a, toList b, toList c, toList d, toList e) where go f' = maybe mempty (\(x, xs) -> uncurry5 f' x `cons` go f' xs) . uncons5 -- | Like 'zipWith', but works with 6 collections. zipWith6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e , Sequential f) => (Element a -> Element b -> Element c -> Element d -> Element e -> Element f -> Element col) -> a -> b -> c -> d -> e -> f -> col zipWith6 fn a b c d e f = go fn (toList a, toList b, toList c, toList d, toList e, toList f) where go f' = maybe mempty (\(x, xs) -> uncurry6 f' x `cons` go f' xs) . uncons6 -- | Like 'zipWith', but works with 7 collections. zipWith7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e , Sequential f, Sequential g ) => (Element a -> Element b -> Element c -> Element d -> Element e -> Element f -> Element g -> Element col) -> a -> b -> c -> d -> e -> f -> g -> col zipWith7 fn a b c d e f g = go fn (toList a, toList b, toList c, toList d, toList e, toList f, toList g) where go f' = maybe mempty (\(x, xs) -> uncurry7 f' x `cons` go f' xs) . uncons7 instance Zippable [c] instance UV.PrimType ty => Zippable (UV.UArray ty) where zipWith f as bs = runST $ UV.builderBuild_ 64 $ go f (toList as) (toList bs) where go _ [] _ = return () go _ _ [] = return () go f' (a':as') (b':bs') = UV.builderAppend (f' a' b') >> go f' as' bs' instance Zippable (BA.Array ty) where zipWith f as bs = runST $ BA.builderBuild_ 64 $ go f (toList as) (toList bs) where go _ [] _ = return () go _ _ [] = return () go f' (a':as') (b':bs') = BA.builderAppend (f' a' b') >> go f' as' bs' instance Zippable S.String where zipWith f as bs = runST $ S.builderBuild_ 64 $ go f (toList as) (toList bs) where go _ [] _ = return () go _ _ [] = return () go f' (a':as') (b':bs') = S.builderAppend (f' a' b') >> go f' as' bs' deriving instance Zippable AsciiString class Zippable col => BoxedZippable col where -- | 'zip' takes two collections and returns a collections of corresponding -- pairs. If one input collection is short, excess elements of the longer -- collection are discarded. zip :: ( Sequential a, Sequential b , Element col ~ (Element a, Element b) ) => a -> b -> col zip = zipWith (,) -- | Like 'zip', but works with 3 collections. zip3 :: ( Sequential a, Sequential b, Sequential c , Element col ~ (Element a, Element b, Element c) ) => a -> b -> c -> col zip3 = zipWith3 (,,) -- | Like 'zip', but works with 4 collections. zip4 :: ( Sequential a, Sequential b, Sequential c, Sequential d , Element col ~ (Element a, Element b, Element c, Element d) ) => a -> b -> c -> d -> col zip4 = zipWith4 (,,,) -- | Like 'zip', but works with 5 collections. zip5 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e , Element col ~ (Element a, Element b, Element c, Element d, Element e) ) => a -> b -> c -> d -> e -> col zip5 = zipWith5 (,,,,) -- | Like 'zip', but works with 6 collections. zip6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f) ) => a -> b -> c -> d -> e -> f -> col zip6 = zipWith6 (,,,,,) -- | Like 'zip', but works with 7 collections. zip7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f, Sequential g , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f, Element g) ) => a -> b -> c -> d -> e -> f -> g -> col zip7 = zipWith7 (,,,,,,) -- | 'unzip' transforms a collection of pairs into a collection of first -- components and a collection of second components. unzip :: (Sequential a, Sequential b, Element col ~ (Element a, Element b)) => col -> (a, b) unzip = go . toList where go [] = (mempty, mempty) go ((a, b):xs) = let (as, bs) = go xs in (a `cons` as, b `cons` bs) -- | Like 'unzip', but works on a collection of 3-element tuples. unzip3 :: ( Sequential a, Sequential b, Sequential c , Element col ~ (Element a, Element b, Element c) ) => col -> (a, b, c) unzip3 = go . toList where go [] = (mempty, mempty, mempty) go ((a, b, c):xs) = let (as, bs, cs) = go xs in (a `cons` as, b `cons` bs, c `cons` cs) -- | Like 'unzip', but works on a collection of 4-element tuples. unzip4 :: ( Sequential a, Sequential b, Sequential c, Sequential d , Element col ~ (Element a, Element b, Element c, Element d) ) => col -> (a, b, c, d) unzip4 = go . toList where go [] = (mempty, mempty, mempty, mempty) go ((a, b, c, d):xs) = let (as, bs, cs, ds) = go xs in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds) -- | Like 'unzip', but works on a collection of 5-element tuples. unzip5 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e , Element col ~ (Element a, Element b, Element c, Element d, Element e) ) => col -> (a, b, c, d, e) unzip5 = go . toList where go [] = (mempty, mempty, mempty, mempty, mempty) go ((a, b, c, d, e):xs) = let (as, bs, cs, ds, es) = go xs in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es) -- | Like 'unzip', but works on a collection of 6-element tuples. unzip6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f) ) => col -> (a, b, c, d, e, f) unzip6 = go . toList where go [] = (mempty, mempty, mempty, mempty, mempty, mempty) go ((a, b, c, d, e, f):xs) = let (as, bs, cs, ds, es, fs) = go xs in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es, f `cons` fs) -- | Like 'unzip', but works on a collection of 7-element tuples. unzip7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e, Sequential f, Sequential g , Element col ~ (Element a, Element b, Element c, Element d, Element e, Element f, Element g) ) => col -> (a, b, c, d, e, f, g) unzip7 = go . toList where go [] = (mempty, mempty, mempty, mempty, mempty, mempty, mempty) go ((a, b, c, d, e, f, g):xs) = let (as, bs, cs, ds, es, fs, gs) = go xs in (a `cons` as, b `cons` bs, c `cons` cs, d `cons` ds, e `cons` es, f `cons` fs, g `cons` gs) instance BoxedZippable [a] instance BoxedZippable (BA.Array ty) -- * Tuple helper functions uncons2 :: (Sequential a, Sequential b) => (a, b) -> Maybe ((Element a, Element b), (a, b)) uncons2 xs = let (as, bs) = xs in do (a', as') <- uncons as (b', bs') <- uncons bs return ((a', b'), (as', bs')) uncons3 :: (Sequential a, Sequential b, Sequential c) => (a, b, c) -> Maybe ((Element a, Element b, Element c), (a, b, c)) uncons3 xs = let (as, bs, cs) = xs in do (a', as') <- uncons as (b', bs') <- uncons bs (c', cs') <- uncons cs return ((a', b', c'), (as', bs', cs')) uncons4 :: (Sequential a, Sequential b, Sequential c, Sequential d) => (a, b, c, d) -> Maybe ( (Element a, Element b, Element c, Element d) , (a, b, c, d) ) uncons4 xs = let (as, bs, cs, ds) = xs in do (a', as') <- uncons as (b', bs') <- uncons bs (c', cs') <- uncons cs (d', ds') <- uncons ds return ((a', b', c', d'), (as', bs', cs', ds')) uncons5 :: (Sequential a, Sequential b, Sequential c, Sequential d, Sequential e) => (a, b, c, d, e) -> Maybe ( (Element a, Element b, Element c, Element d, Element e) , (a, b, c, d, e) ) uncons5 xs = let (as, bs, cs, ds, es) = xs in do (a', as') <- uncons as (b', bs') <- uncons bs (c', cs') <- uncons cs (d', ds') <- uncons ds (e', es') <- uncons es return ((a', b', c', d', e'), (as', bs', cs', ds', es')) uncons6 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e , Sequential f ) => (a, b, c, d, e, f) -> Maybe ( (Element a, Element b, Element c, Element d, Element e, Element f) , (a, b, c, d, e, f) ) uncons6 xs = let (as, bs, cs, ds, es, fs) = xs in do (a', as') <- uncons as (b', bs') <- uncons bs (c', cs') <- uncons cs (d', ds') <- uncons ds (e', es') <- uncons es (f', fs') <- uncons fs return ((a', b', c', d', e', f'), (as', bs', cs', ds', es', fs')) uncons7 :: ( Sequential a, Sequential b, Sequential c, Sequential d, Sequential e , Sequential f, Sequential g ) => (a, b, c, d, e, f, g) -> Maybe ( (Element a, Element b, Element c, Element d, Element e, Element f , Element g) , (a, b, c, d, e, f, g) ) uncons7 xs = let (as, bs, cs, ds, es, fs, gs) = xs in do (a', as') <- uncons as (b', bs') <- uncons bs (c', cs') <- uncons cs (d', ds') <- uncons ds (e', es') <- uncons es (f', fs') <- uncons fs (g', gs') <- uncons gs return ( (a', b', c', d', e', f', g') , (as', bs', cs', ds', es', fs', gs') ) uncurry2 :: (a -> b -> c) -> (a, b) -> c uncurry2 = Prelude.uncurry uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 fn (a, b, c) = fn a b c uncurry4 :: (a -> b -> c -> d -> g) -> (a, b, c, d) -> g uncurry4 fn (a, b, c, d) = fn a b c d uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f uncurry5 fn (a, b, c, d, e) = fn a b c d e uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g uncurry6 fn (a, b, c, d, e, f) = fn a b c d e f uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a, b, c, d, e, f, g) -> h uncurry7 fn (a, b, c, d, e, f, g) = fn a b c d e f g foundation-0.0.23/Foundation/Collection/Mappable.hs0000644000000000000000000001006613415353646020423 0ustar0000000000000000-- | -- Module : Basement.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 Basement.Compat.Base import qualified Data.Traversable import Basement.BoxedArray (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) foundation-0.0.23/Foundation/Conduit/Internal.hs0000644000000000000000000003501613415353646017772 0ustar0000000000000000-- Module : Foundation.Conduit.Internal -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- -- Taken from the conduit package almost verbatim, and -- Copyright (c) 2012 Michael Snoyman -- {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} module Foundation.Conduit.Internal ( Pipe(..) , Conduit(..) , ZipSink(..) , ResourceT(..) , MonadResource(..) , runResourceT , await , awaitForever , yield , yieldOr , leftover , runConduit , runConduitRes , runConduitPure , fuse , bracketConduit ) where import Basement.Imports hiding (throw) import Foundation.Monad import Foundation.Numerical import Basement.Monad import Control.Monad ((>=>), liftM, void, mapM_, join) import Control.Exception (SomeException, mask_) import Data.IORef (atomicModifyIORef) -- | A pipe producing and consuming values -- -- A basic intuition is that every @Pipe@ produces a stream of /output/ values -- and eventually indicates that this stream is terminated by sending a -- /result/. On the receiving end of a @Pipe@, these become the /input/ and /upstream/ -- parameters. data Pipe leftOver input output upstream monad result = -- | Provide new output to be sent downstream. This constructor has three -- fields: the next @Pipe@ to be used, a finalization function, and the -- output value. Yield (Pipe leftOver input output upstream monad result) (monad ()) output -- | Request more input from upstream. The first field takes a new input -- value and provides a new @Pipe@. The second takes an upstream result -- value, which indicates that upstream is producing no more results. | Await (input -> Pipe leftOver input output upstream monad result) (upstream -> Pipe leftOver input output upstream monad result) -- | Processing with this @Pipe@ is complete, providing the final result. | Done result -- | Require running of a monadic action to get the next @Pipe@. | PipeM (monad (Pipe leftOver input output upstream monad result)) -- | Return leftover input, which should be provided to future operations. | Leftover (Pipe leftOver input output upstream monad result) leftOver instance Applicative m => Functor (Pipe l i o u m) where fmap = (<$>) {-# INLINE fmap #-} instance Applicative m => Applicative (Pipe l i o u m) where pure = Done {-# INLINE pure #-} Yield p c o <*> fa = Yield (p <*> fa) c o Await p c <*> fa = Await (\i -> p i <*> fa) (\o -> c o <*> fa) Done r <*> fa = r <$> fa PipeM mp <*> fa = PipeM ((<*> fa) <$> mp) Leftover p i <*> fa = Leftover (p <*> fa) i {-# INLINE (<*>) #-} instance (Functor m, Monad m) => Monad (Pipe l i o u m) where return = Done {-# INLINE return #-} Yield p c o >>= fp = Yield (p >>= fp) c o Await p c >>= fp = Await (p >=> fp) (c >=> fp) Done x >>= fp = fp x PipeM mp >>= fp = PipeM ((>>= fp) <$> mp) Leftover p i >>= fp = Leftover (p >>= fp) i -- | A component of a conduit pipeline, which takes a stream of -- @input@, produces a stream of @output@, performs actions in the -- underlying @monad@, and produces a value of @result@ when no more -- output data is available. newtype Conduit input output monad result = Conduit { unConduit :: forall a . (result -> Pipe input input output () monad a) -> Pipe input input output () monad a } instance Functor (Conduit i o m) where fmap f (Conduit c) = Conduit $ \resPipe -> c (resPipe . f) instance Applicative (Conduit i o m) where pure x = Conduit ($ x) {-# INLINE pure #-} fab <*> fa = fab >>= \ab -> fa >>= \a -> pure (ab a) {-# INLINE (<*>) #-} instance Monad (Conduit i o m) where return = pure Conduit f >>= g = Conduit $ \h -> f $ \a -> unConduit (g a) h instance MonadTrans (Conduit i o) where lift m = Conduit $ \rest -> PipeM $ liftM rest m instance MonadIO m => MonadIO (Conduit i o m) where liftIO = lift . liftIO instance MonadFailure m => MonadFailure (Conduit i o m) where type Failure (Conduit i o m) = Failure m mFail = lift . mFail instance MonadThrow m => MonadThrow (Conduit i o m) where throw = lift . throw instance MonadCatch m => MonadCatch (Conduit i o m) where catch (Conduit c0) onExc = Conduit $ \rest -> let go (PipeM m) = PipeM $ catch (liftM go m) (return . flip unConduit rest . onExc) go (Done r) = rest r go (Await p c) = Await (go . p) (go . c) go (Yield p m o) = Yield (go p) m o go (Leftover p i) = Leftover (go p) i in go (c0 Done) -- | Await for a value from upstream. await :: Conduit i o m (Maybe i) await = Conduit $ \f -> Await (f . Just) (const (f Nothing)) {-# NOINLINE[1] await #-} await' :: Conduit i o m r -> (i -> Conduit i o m r) -> Conduit i o m r await' f g = Conduit $ \rest -> Await (\i -> unConduit (g i) rest) (const $ unConduit f rest) {-# INLINE await' #-} {-# RULES "conduit: await >>= maybe" [2] forall x y. await >>= maybe x y = await' x y #-} awaitForever :: (input -> Conduit input output monad b) -> Conduit input output monad () awaitForever f = Conduit $ \rest -> let go = Await (\i -> unConduit (f i) (const go)) rest in go -- | Send a value downstream. yield :: Monad m => o -> Conduit i o m () yield o = Conduit $ \f -> Yield (f ()) (return ()) o -- | Same as 'yield', but additionally takes a finalizer to be run if -- the downstream component terminates. yieldOr :: o -> m () -- ^ finalizer -> Conduit i o m () yieldOr o m = Conduit $ \f -> Yield (f ()) m o -- | Provide leftover input to be consumed by the next component in -- the current monadic binding. leftover :: i -> Conduit i o m () leftover i = Conduit $ \f -> Leftover (f ()) i -- | Run a conduit pipeline to completion. runConduit :: Monad m => Conduit () () m r -> m r runConduit (Conduit f) = runPipe (f Done) -- | Run a pure conduit pipeline to completion. runConduitPure :: Conduit () () Identity r -> r runConduitPure = runIdentity . runConduit -- | Run a conduit pipeline in a 'ResourceT' context for acquiring resources. runConduitRes :: (MonadBracket m, MonadIO m) => Conduit () () (ResourceT m) r -> m r runConduitRes = runResourceT . runConduit bracketConduit :: MonadResource m => IO a -> (a -> IO b) -> (a -> Conduit i o m r) -> Conduit i o m r bracketConduit acquire cleanup inner = do (resource, release) <- allocate acquire cleanup result <- inner resource release return result -- | Internal: run a @Pipe@ runPipe :: Monad m => Pipe () () () () m r -> m r runPipe = go where go (Yield p _ ()) = go p go (Await _ p) = go (p ()) go (Done r) = return r go (PipeM mp) = mp >>= go go (Leftover p ()) = go p -- | Send the output of the first Conduit component to the second -- Conduit component. fuse :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r fuse (Conduit left0) (Conduit right0) = Conduit $ \rest -> let goRight final left right = case right of Yield p c o -> Yield (recurse p) (c >> final) o Await rp rc -> goLeft rp rc final left Done r2 -> PipeM (final >> return (rest r2)) PipeM mp -> PipeM (liftM recurse mp) Leftover right' i -> goRight final (Yield left final i) right' where recurse = goRight final left goLeft rp rc final left = case left of Yield left' final' o -> goRight final' left' (rp o) Await left' lc -> Await (recurse . left') (recurse . lc) Done r1 -> goRight (return ()) (Done r1) (rc r1) PipeM mp -> PipeM (liftM recurse mp) Leftover left' i -> Leftover (recurse left') i where recurse = goLeft rp rc final in goRight (return ()) (left0 Done) (right0 Done) {- FIXME for later, if we add resourcet -- | Safely acquire a resource and register a cleanup action for it, -- in the context of a 'Conduit'. bracketConduit :: MonadResource m => IO a -- ^ acquire -> (a -> IO ()) -- ^ cleanup -> (a -> Conduit i o m r) -> Conduit i o m r bracketConduit alloc cleanup inner = Conduit $ \rest -> PipeM $ do (key, val) <- allocate alloc cleanup return $ unConduit (addCleanup (const $ release key) (inside seed)) rest addCleanup :: Monad m => (Bool -> m ()) -> Conduit i o m r -> Conduit i o m r addCleanup cleanup (Conduit c0) = Conduit $ \rest -> let go (Done r) = PipeM (cleanup True >> return (rest r)) go (Yield src close x) = Yield (go src) (cleanup False >> close) x go (PipeM msrc) = PipeM (liftM (go) msrc) go (Await p c) = Await (go . p) (go . c) go (Leftover p i) = Leftover (go p) i in go (c0 Done) -} newtype ZipSink i m r = ZipSink { getZipSink :: Conduit i () m r } instance Monad m => Functor (ZipSink i m) where fmap f (ZipSink x) = ZipSink (liftM f x) instance Monad m => Applicative (ZipSink i m) where pure = ZipSink . return ZipSink (Conduit f0) <*> ZipSink (Conduit x0) = ZipSink $ Conduit $ \rest -> let go (Leftover _ i) _ = absurd i go _ (Leftover _ i) = absurd i go (Yield f _ ()) x = go f x go f (Yield x _ ()) = go f x go (PipeM mf) x = PipeM (liftM (`go` x) mf) go f (PipeM mx) = PipeM (liftM (go f) mx) go (Done f) (Done x) = rest (f x) go (Await pf cf) (Await px cx) = Await (\i -> go (pf i) (px i)) (\() -> go (cf ()) (cx ())) go (Await pf cf) x@Done{} = Await (\i -> go (pf i) x) (\() -> go (cf ()) x) go f@Done{} (Await px cx) = Await (\i -> go f (px i)) (\() -> go f (cx ())) in go (injectLeftovers (f0 Done)) (injectLeftovers (x0 Done)) data Void absurd :: Void -> a absurd _ = error "Foundation.Conduit.Internal.absurd" injectLeftovers :: Monad m => Pipe i i o u m r -> Pipe l i o u m r injectLeftovers = go [] where go ls (Yield p c o) = Yield (go ls p) c o go (l:ls) (Await p _) = go ls $ p l go [] (Await p c) = Await (go [] . p) (go [] . c) go _ (Done r) = Done r go ls (PipeM mp) = PipeM (liftM (go ls) mp) go ls (Leftover p l) = go (l:ls) p --------------------- -- ResourceT --------------------- newtype ResourceT m a = ResourceT { unResourceT :: PrimVar IO ReleaseMap -> m a } instance Functor m => Functor (ResourceT m) where fmap f (ResourceT m) = ResourceT $ \r -> fmap f (m r) instance Applicative m => Applicative (ResourceT m) where pure = ResourceT . const . pure ResourceT mf <*> ResourceT ma = ResourceT $ \r -> mf r <*> ma r instance Monad m => Monad (ResourceT m) where #if !MIN_VERSION_base(4,8,0) return = ResourceT . const . return #endif ResourceT ma >>= f = ResourceT $ \r -> do a <- ma r let ResourceT f' = f a f' r instance MonadTrans ResourceT where lift = ResourceT . const instance MonadIO m => MonadIO (ResourceT m) where liftIO = lift . liftIO instance MonadThrow m => MonadThrow (ResourceT m) where throw = lift . throw instance MonadCatch m => MonadCatch (ResourceT m) where catch (ResourceT f) g = ResourceT $ \env -> f env `catch` \e -> unResourceT (g e) env instance MonadBracket m => MonadBracket (ResourceT m) where generalBracket acquire onSuccess onExc inner = ResourceT $ \env -> generalBracket (unResourceT acquire env) (\x y -> unResourceT (onSuccess x y) env) (\x y -> unResourceT (onExc x y) env) (\x -> unResourceT (inner x) env) data ReleaseMap = ReleaseMap !NextKey !RefCount ![(Word, (ReleaseType -> IO ()))] -- FIXME use a proper Map? | ReleaseMapClosed data ReleaseType = ReleaseEarly | ReleaseNormal | ReleaseException type RefCount = Word type NextKey = Word runResourceT :: (MonadBracket m, MonadIO m) => ResourceT m a -> m a runResourceT (ResourceT inner) = generalBracket (liftIO $ primVarNew $ ReleaseMap maxBound (minBound + 1) []) (\state _res -> liftIO $ cleanup state ReleaseNormal) (\state _exc -> liftIO $ cleanup state ReleaseException) inner where cleanup istate rtype = do mm <- atomicModifyIORef istate $ \rm -> case rm of ReleaseMap nk rf m -> let rf' = rf - 1 in if rf' == minBound then (ReleaseMapClosed, Just m) else (ReleaseMap nk rf' m, Nothing) ReleaseMapClosed -> error "runResourceT: cleanup on ReleaseMapClosed" case mm of Just m -> mapM_ (\(_, x) -> ignoreExceptions (x rtype)) m Nothing -> return () where ignoreExceptions io = void io `catch` (\(_ :: SomeException) -> return ()) allocate :: (MonadResource m, MonadIO n) => IO a -> (a -> IO b) -> m (a, n ()) allocate acquire release = liftResourceT $ ResourceT $ \istate -> liftIO $ mask_ $ do a <- acquire key <- atomicModifyIORef istate $ \rm -> case rm of ReleaseMap key rf m -> ( ReleaseMap (key - 1) rf ((key, const $ void $ release a) : m) , key ) ReleaseMapClosed -> error "allocate: ReleaseMapClosed" let release' = join $ atomicModifyIORef istate $ \rm -> case rm of ReleaseMap nextKey rf m -> let loop front [] = (ReleaseMap nextKey rf (front []), return ()) loop front ((key', action):rest) | key == key' = ( ReleaseMap nextKey rf (front rest) , action ReleaseEarly ) | otherwise = loop (front . ((key', action):)) rest in loop id m ReleaseMapClosed -> error "allocate: ReleaseMapClosed (2)" return (a, liftIO release') class MonadIO m => MonadResource m where liftResourceT :: ResourceT IO a -> m a instance MonadIO m => MonadResource (ResourceT m) where liftResourceT (ResourceT f) = ResourceT (liftIO . f) instance MonadResource m => MonadResource (Conduit i o m) where liftResourceT = lift . liftResourceT foundation-0.0.23/Foundation/Format/CSV/Types.hs0000644000000000000000000002310713415353646017576 0ustar0000000000000000-- | -- Module : Foundation.Format.CSV.Types -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Format.CSV.Types (-- * CSV CSV , unCSV -- * Row , Row , unRow , Record(..) -- * Field , Field(..) , Escaping(..) , IsField(..) -- ** helpers , integral , float , string ) where import Basement.Imports import Basement.BoxedArray (Array, length, unsafeIndex) import Basement.NormalForm (NormalForm(..)) import Basement.From (Into, into) import Basement.String (String, any, elem, null, uncons) import qualified Basement.String as String (singleton) import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import Basement.Types.OffsetSize (Offset, CountOf) import Foundation.Collection.Element (Element) import Foundation.Collection.Collection (Collection, nonEmpty_) import Foundation.Collection.Sequential (Sequential) import Foundation.Collection.Indexed (IndexedCollection) import Foundation.Check.Arbitrary (Arbitrary(..), frequency) import Foundation.String.Read (readDouble, readInteger) -- | CSV field data Field = FieldInteger Integer | FieldDouble Double | FieldString String Escaping deriving (Eq, Show, Typeable) instance NormalForm Field where toNormalForm (FieldInteger i) = toNormalForm i toNormalForm (FieldDouble d) = toNormalForm d toNormalForm (FieldString s e) = toNormalForm s `seq` toNormalForm e instance Arbitrary Field where arbitrary = frequency $ nonEmpty_ [ (1, FieldInteger <$> arbitrary) , (1, FieldDouble <$> arbitrary) , (3, string <$> arbitrary) ] data Escaping = NoEscape | Escape | DoubleEscape deriving (Eq, Ord, Enum, Bounded, Show, Typeable) instance NormalForm Escaping where toNormalForm !_ = () class IsField a where toField :: a -> Field fromField :: Field -> Either String a instance IsField Field where toField = id fromField = pure instance IsField a => IsField (Maybe a) where toField Nothing = FieldString mempty NoEscape toField (Just a) = toField a fromField stuff@(FieldString p NoEscape) | null p = pure Nothing | otherwise = Just <$> fromField stuff fromField stuff = Just <$> fromField stuff fromIntegralField :: Integral b => Field -> Either String b fromIntegralField (FieldString str NoEscape) = case readInteger str of Nothing -> Left "Invalid integral field" Just v -> pure $ fromInteger v fromIntegralField (FieldInteger v) = pure (fromInteger v) fromIntegralField _ = Left "Expected integral value" fromDoubleField :: Field -> Either String Double fromDoubleField (FieldString str NoEscape) = case readDouble str of Nothing -> Left "Invalid double field" Just v -> pure v fromDoubleField (FieldDouble v) = pure v fromDoubleField _ = Left "Expected double value" instance IsField Bool where toField = toField . show fromField (FieldString "True" NoEscape) = pure True fromField (FieldString "False" NoEscape) = pure False fromField _ = Left "not a boolean value" instance IsField Int8 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Int16 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Int32 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Int64 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Int where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word8 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word16 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word32 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word64 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word128 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Word256 where toField = FieldInteger . into fromField = fromIntegralField instance IsField Integer where toField = FieldInteger fromField = fromIntegralField instance IsField Natural where toField = FieldInteger . into fromField = fromIntegralField instance IsField Double where toField = FieldDouble fromField = fromDoubleField instance IsField Char where toField = string . String.singleton fromField (FieldString str _) = case uncons str of Just (c, str') | null str' -> pure c | otherwise -> Left "Expected a char, but received a String" Nothing -> Left "Expected a char" fromField _ = Left "Expected a char" instance IsField (Offset a) where toField = FieldInteger . into fromField = fromIntegralField instance IsField (CountOf a) where toField = FieldInteger . into fromField = fromIntegralField instance IsField [Char] where toField = string . fromString fromField (FieldString str _) = pure $ toList str fromField _ = Left "Expected a Lazy String" instance IsField String where toField = string fromField (FieldString str _) = pure str fromField _ = Left "Expected a UTF8 String" -- | helper function to create a `FieldInteger` -- integral :: Into Integer a => a -> Field integral = FieldInteger . into float :: Double -> Field float = FieldDouble -- | heler function to create a FieldString. -- -- This function will findout automatically if an escaping is needed. -- if you wish to perform the escaping manually, do not used this function -- string :: String -> Field string s = FieldString s encoding where encoding | any g s = DoubleEscape | any f s = Escape | otherwise = NoEscape g c = c == '\"' f c = c `elem` ",\r\n" -- | CSV Row -- newtype Row = Row { unRow :: Array Field } deriving (Eq, Show, Typeable, Semigroup, Monoid, Collection, NormalForm, Sequential, IndexedCollection) type instance Element Row = Field instance IsList Row where type Item Row = Field toList = toList . unRow fromList = Row . fromList class Record a where toRow :: a -> Row fromRow :: Row -> Either String a instance Record Row where toRow = id fromRow = pure instance (IsField a, IsField b) => Record (a,b) where toRow (a,b) = fromList [toField a, toField b] fromRow (Row row) | length row == 2 = (,) <$> fromField (row `unsafeIndex` 0) <*> fromField (row `unsafeIndex` 1) | otherwise = Left (show row) instance (IsField a, IsField b, IsField c) => Record (a,b,c) where toRow (a,b,c) = fromList [toField a, toField b, toField c] fromRow (Row row) | length row == 3 = (,,) <$> fromField (row `unsafeIndex` 0) <*> fromField (row `unsafeIndex` 1) <*> fromField (row `unsafeIndex` 2) | otherwise = Left (show row) instance (IsField a, IsField b, IsField c, IsField d) => Record (a,b,c,d) where toRow (a,b,c,d) = fromList [toField a, toField b, toField c, toField d] fromRow (Row row) | length row == 4 = (,,,) <$> fromField (row `unsafeIndex` 0) <*> fromField (row `unsafeIndex` 1) <*> fromField (row `unsafeIndex` 2) <*> fromField (row `unsafeIndex` 3) | otherwise = Left (show row) instance (IsField a, IsField b, IsField c, IsField d, IsField e) => Record (a,b,c,d,e) where toRow (a,b,c,d,e) = fromList [toField a, toField b, toField c, toField d, toField e] fromRow (Row row) | length row == 5 = (,,,,) <$> fromField (row `unsafeIndex` 0) <*> fromField (row `unsafeIndex` 1) <*> fromField (row `unsafeIndex` 2) <*> fromField (row `unsafeIndex` 3) <*> fromField (row `unsafeIndex` 4) | otherwise = Left (show row) instance (IsField a, IsField b, IsField c, IsField d, IsField e, IsField f) => Record (a,b,c,d,e,f) where toRow (a,b,c,d,e,f) = fromList [toField a, toField b, toField c, toField d, toField e, toField f] fromRow (Row row) | length row == 6 = (,,,,,) <$> fromField (row `unsafeIndex` 0) <*> fromField (row `unsafeIndex` 1) <*> fromField (row `unsafeIndex` 2) <*> fromField (row `unsafeIndex` 3) <*> fromField (row `unsafeIndex` 4) <*> fromField (row `unsafeIndex` 5) | otherwise = Left (show row) -- | CSV Type newtype CSV = CSV { unCSV :: Array Row } deriving (Eq, Show, Typeable, Semigroup, Monoid, Collection, NormalForm, Sequential, IndexedCollection) type instance Element CSV = Row instance IsList CSV where type Item CSV = Row toList = toList . unCSV fromList = CSV . fromList foundation-0.0.23/Foundation/Format/CSV/Builder.hs0000644000000000000000000000472513415353646020065 0ustar0000000000000000-- | -- Module : Foundation.Format.CSV.Builder -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- -- Provies the support for Comma Separated Value {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Foundation.Format.CSV.Builder ( -- * String Bulider csvStringBuilder , rowStringBuilder , fieldStringBuilder -- * Block Builder , csvBlockBuilder , rowBlockBuilder , fieldBlockBuilder -- * Conduit , rowC ) where import Basement.Imports import Basement.String (replace) import Foundation.Collection.Sequential (Sequential(intersperse)) import Foundation.Conduit.Internal import qualified Foundation.String.Builder as String import Basement.Block (Block) import qualified Basement.Block.Builder as Block import GHC.ST (runST) import Foundation.Format.CSV.Types -- | serialise the CSV document into a UTF8 string csvStringBuilder :: CSV -> String.Builder csvStringBuilder = String.unsafeStringBuilder . csvBlockBuilder rowStringBuilder :: Row -> String.Builder rowStringBuilder = String.unsafeStringBuilder . rowBlockBuilder fieldStringBuilder :: Field -> String.Builder fieldStringBuilder = String.unsafeStringBuilder . fieldBlockBuilder -- | serialise the CSV document into a UTF8 encoded (Block Word8) csvBlockBuilder :: CSV -> Block.Builder csvBlockBuilder = mconcat . intersperse (Block.emitString "\r\n") . fmap rowBlockBuilder . toList . unCSV rowBlockBuilder :: Row -> Block.Builder rowBlockBuilder = mconcat . intersperse (Block.emitUTF8Char ',') . fmap fieldBlockBuilder . toList . unRow fieldBlockBuilder :: Field -> Block.Builder fieldBlockBuilder (FieldInteger i) = Block.emitString $ show i fieldBlockBuilder (FieldDouble d) = Block.emitString $ show d fieldBlockBuilder (FieldString s e) = case e of NoEscape -> Block.emitString s Escape -> Block.emitUTF8Char '"' <> Block.emitString s <> Block.emitUTF8Char '"' DoubleEscape -> Block.emitUTF8Char '"' <> Block.emitString (replace "\"" "\"\"" s) <> Block.emitUTF8Char '"' rowC :: (Record row, Monad m) => Conduit row (Block Word8) m () rowC = await >>= go where go Nothing = pure () go (Just r) = let bytes = runST (Block.run $ rowBlockBuilder (toRow r) <> Block.emitString "\r\n") in yield bytes >> await >>= go foundation-0.0.23/Foundation/Format/CSV/Parser.hs0000644000000000000000000000607013415353646017726 0ustar0000000000000000-- | CSV parser as specified in RFC4180 -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Foundation.Format.CSV.Parser ( file , recordC , record , record_ , field ) where import Basement.Imports hiding (throw) import Foundation.Format.CSV.Types import Basement.String (snoc) import Foundation.Parser import Foundation.Monad import Foundation.Collection (Collection (elem)) import Foundation.Conduit import Control.Monad (void) import Data.Typeable (typeRep) import Data.Proxy (Proxy(..)) recordC :: (Monad m, MonadThrow m) => Conduit String Row m () recordC = awaitForever $ recordC' . parse (record <* optional (elements crlf)) where recordC' (ParseFailed err) = throw err recordC' (ParseOk rest v) = leftover rest *> yield v recordC' (ParseMore more) = do mm <- await case mm of Nothing -> throw (NotEnoughParseOnly :: ParseError String) Just b -> recordC' (more b) record_ :: forall row . (Typeable row, Record row) => Parser String row record_ = do rs <- record case fromRow rs of Left err -> reportError $ Expected (show $ typeRep (Proxy @row)) err Right v -> pure v file :: Parser String CSV file = do mh <- optional $ header <* elements crlf x <- record xs <- some $ elements crlf *> record void $ optional $ elements crlf pure $ fromList $ case mh of Nothing -> x : xs Just h -> h : x : xs header :: Parser String Row header = do x <- name xs <- some $ element comma *> name pure $ fromList $ x : xs record :: Parser String Row record = do x <- field xs <- some $ element comma *> field pure $ fromList $ x : xs name :: Parser String Field name = field {-# INLINE name #-} field :: Parser String Field field = escaped <|> nonEscaped escaped :: Parser String Field escaped = element dquote *> escaped' where escaped' = do x <- takeWhile (dquote /=) element dquote p <- peek if p == (Just dquote) then skip 1 >> descaped' (snoc x dquote) else pure (FieldString x Escape) descaped' acc = do x <- takeWhile (dquote /=) element dquote p <- peek if p == (Just dquote) then skip 1 >> descaped' (acc <> snoc x dquote) else pure (FieldString (acc <> x) DoubleEscape) nonEscaped :: Parser String Field nonEscaped = flip FieldString NoEscape <$> takeWhile (not . flip elem specials) {-# INLINE nonEscaped #-} comma :: Char comma = ',' {-# INLINE comma #-} cr :: Char cr = '\r' {-# INLINE cr #-} dquote :: Char dquote = '"' {-# INLINE dquote #-} lf :: Char lf = '\n' {-# INLINE lf #-} crlf :: String crlf = fromList [cr, lf] {-# NOINLINE crlf #-} {- textdataQuoted :: String textdataQuoted = textdata <> specials {-# NOINLINE textdataQuoted #-} -} specials :: String specials = ",\r\n" {-# INLINE specials #-} {- textdata :: String textdata = fromList $ [' '..'!'] <> ['#'..'+'] <> ['-'..'~'] {-# NOINLINE textdata #-} -} foundation-0.0.23/Foundation/Numerical/Floating.hs0000644000000000000000000000175113415353646020272 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} module Foundation.Numerical.Floating ( FloatingPoint(..) ) where import Basement.Compat.Base import Data.Proxy import qualified Prelude -- | IEEE754 Floating Point class FloatingPoint a where floatRadix :: Proxy a -> Integer floatDigits :: Proxy a -> Int floatRange :: Proxy a -> (Int, Int) floatDecode :: a -> (Integer, Int) floatEncode :: Integer -> Int -> a instance FloatingPoint Float where floatRadix _ = Prelude.floatRadix (0.0 :: Float) floatDigits _ = Prelude.floatDigits (0.0 :: Float) floatRange _ = Prelude.floatRange (0.0 :: Float) floatDecode = Prelude.decodeFloat floatEncode = Prelude.encodeFloat instance FloatingPoint Double where floatRadix _ = Prelude.floatRadix (0.0 :: Double) floatDigits _ = Prelude.floatDigits (0.0 :: Double) floatRange _ = Prelude.floatRange (0.0 :: Double) floatDecode = Prelude.decodeFloat floatEncode = Prelude.encodeFloat foundation-0.0.23/Foundation/IO/File.hs0000644000000000000000000001052013415353646015770 0ustar0000000000000000-- | -- Module : Foundation.IO.File -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : portable -- {-# LANGUAGE OverloadedStrings #-} module Foundation.IO.File ( FilePath , openFile , closeFile , IOMode(..) , withFile , hGet , hGetNonBlocking , hGetSome , hPut , readFile ) where import System.IO (Handle, IOMode) import System.IO.Error import qualified System.IO as S import Foundation.Collection import Foundation.VFS import Basement.Types.OffsetSize import Basement.Imports import Foundation.Array.Internal import Foundation.Numerical import qualified Basement.UArray.Mutable as V import qualified Basement.UArray as V import Control.Exception (bracket) import Foreign.Ptr (plusPtr) -- | list the file name in the given FilePath directory -- -- TODO: error management and not implemented yet --getDirectory :: FilePath -> IO [FileName] --getDirectory = undefined -- | Open a new handle on the file openFile :: FilePath -> IOMode -> IO Handle openFile filepath mode = do S.openBinaryFile (filePathToLString filepath) mode -- | Close a handle closeFile :: Handle -> IO () closeFile = S.hClose -- | Read binary data directly from the specified 'Handle'. -- -- First argument is the Handle to read from, and the second is the number of bytes to read. -- It returns the bytes read, up to the specified size, or an empty array if EOF has been reached. -- -- 'hGet' is implemented in terms of 'hGetBuf'. hGet :: Handle -> Int -> IO (UArray Word8) hGet h size | size < 0 = invalidBufferSize "hGet" h size | otherwise = V.createFromIO (CountOf size) $ \p -> (CountOf <$> S.hGetBuf h p size) -- | hGetNonBlocking is similar to 'hGet', except that it will never block -- waiting for data to become available, instead it returns only whatever data -- is available. If there is no data available to be read, 'hGetNonBlocking' -- returns an empty array. -- -- Note: on Windows, this function behaves identically to 'hGet'. hGetNonBlocking :: Handle -> Int -> IO (UArray Word8) hGetNonBlocking h size | size < 0 = invalidBufferSize "hGetNonBlocking" h size | otherwise = V.createFromIO (CountOf size) $ \p -> (CountOf <$> S.hGetBufNonBlocking h p size) -- | Like 'hGet', except that a shorter array may be returned -- if there are not enough bytes immediately available to satisfy the -- whole request. 'hGetSome' only blocks if there is no data -- available, and EOF has not yet been reached. -- hGetSome :: Handle -> Int -> IO (UArray Word8) hGetSome h size | size < 0 = invalidBufferSize "hGetSome" h size | otherwise = V.createFromIO (CountOf size) $ \p -> (CountOf <$> S.hGetBufSome h p size) hPut :: Handle -> (UArray Word8) -> IO () hPut h arr = withPtr arr $ \ptr -> S.hPutBuf h ptr (let (CountOf sz) = length arr in sz) invalidBufferSize :: [Char] -> Handle -> Int -> IO a invalidBufferSize functionName handle size = ioError $ mkIOError illegalOperationErrorType (functionName <> " invalid array size: " <> toList (show size)) (Just handle) Nothing -- | @'withFile' filepath mode act@ opens a file using the mode@ -- and run act@. the by-product handle will be closed when act finish, -- either normally or through an exception. -- -- The value returned is the result of act@ withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r withFile fp mode act = bracket (openFile fp mode) closeFile act -- | Read a binary file and return the whole content in one contiguous buffer. readFile :: FilePath -> IO (UArray Word8) readFile fp = withFile fp S.ReadMode $ \h -> do -- TODO filesize is an integer (whyyy ?!), and transforming to Int using -- fromIntegral is probably the wrong thing to do here.. sz <- S.hFileSize h mv <- V.newPinned (CountOf $ fromInteger sz) V.withMutablePtr mv $ loop h (fromInteger sz) unsafeFreeze mv where loop h left dst | left == 0 = return () | otherwise = do let toRead = min blockSize left r <- S.hGetBuf h dst toRead if r > 0 && r <= toRead then loop h (left - r) (dst `plusPtr` r) else error "readFile: " -- turn into proper error blockSize :: Int blockSize = 4096 foundation-0.0.23/Foundation/Monad/MonadIO.hs0000644000000000000000000000071213415353646017130 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} module Foundation.Monad.MonadIO ( MonadIO(..) ) where #if MIN_VERSION_base(4,9,0) import Control.Monad.IO.Class #else import Basement.Compat.Base import Basement.Compat.AMP -- | Monads in which 'IO' computations may be embedded. class AMPMonad m => MonadIO m where -- | Lift a computation from the 'IO' monad. liftIO :: IO a -> m a instance MonadIO IO where liftIO io = io #endif foundation-0.0.23/Foundation/Monad/Exception.hs0000644000000000000000000000420013415353646017574 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} module Foundation.Monad.Exception ( MonadThrow(..) , MonadCatch(..) , MonadBracket(..) ) where import Basement.Compat.Base import Basement.Compat.AMP import qualified Control.Exception as E -- | Monad that can throw exception class AMPMonad m => MonadThrow m where -- | Throw immediatity an exception. -- Only a 'MonadCatch' monad will be able to catch the exception using 'catch' throw :: Exception e => e -> m a -- | Monad that can catch exception class MonadThrow m => MonadCatch m where catch :: Exception e => m a -> (e -> m a) -> m a -- | Monad that can ensure cleanup actions are performed even in the -- case of exceptions, both synchronous and asynchronous. This usually -- excludes continuation-based monads. class MonadCatch m => MonadBracket m where -- | A generalized version of the standard bracket function which -- allows distinguishing different exit cases. generalBracket :: m a -- ^ acquire some resource -> (a -> b -> m ignored1) -- ^ cleanup, no exception thrown -> (a -> E.SomeException -> m ignored2) -- ^ cleanup, some exception thrown. The exception will be rethrown -> (a -> m b) -- ^ inner action to perform with the resource -> m b instance MonadThrow IO where throw = E.throwIO instance MonadCatch IO where catch = E.catch instance MonadBracket IO where generalBracket acquire onSuccess onException inner = E.mask $ \restore -> do x <- acquire res1 <- E.try $ restore $ inner x case res1 of Left (e1 :: E.SomeException) -> do -- explicitly ignore exceptions from the cleanup -- action so we keep the original exception E.uninterruptibleMask_ $ fmap (const ()) (onException x e1) `E.catch` (\(_ :: E.SomeException) -> return ()) E.throwIO e1 Right y -> do -- Allow exceptions from the onSuccess function to propagate _ <- onSuccess x y return y foundation-0.0.23/Foundation/Monad/Transformer.hs0000644000000000000000000000047113415353646020146 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} module Foundation.Monad.Transformer ( MonadTrans(..) ) where import Basement.Compat.AMP -- | Basic Transformer class class MonadTrans trans where -- | Lift a computation from an inner monad to the current transformer monad lift :: AMPMonad m => m a -> trans m a foundation-0.0.23/Foundation/Monad/Identity.hs0000644000000000000000000000300413415353646017430 0ustar0000000000000000-- | -- The identity monad transformer. -- -- This is useful for functions parameterized by a monad transformer. -- module Foundation.Monad.Identity ( IdentityT , runIdentityT ) where import Basement.Compat.Base hiding (throw) import Basement.Monad (MonadFailure(..)) import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer -- | Identity Transformer newtype IdentityT m a = IdentityT { runIdentityT :: m a } instance Functor m => Functor (IdentityT m) where fmap f (IdentityT m) = IdentityT (f `fmap` m) {-# INLINE fmap #-} instance Applicative m => Applicative (IdentityT m) where pure x = IdentityT (pure x) {-# INLINE pure #-} fab <*> fa = IdentityT (runIdentityT fab <*> runIdentityT fa) {-# INLINE (<*>) #-} instance Monad m => Monad (IdentityT m) where return x = IdentityT (return x) {-# INLINE return #-} ma >>= mb = IdentityT $ runIdentityT ma >>= runIdentityT . mb {-# INLINE (>>=) #-} instance MonadTrans IdentityT where lift = IdentityT {-# INLINE lift #-} instance MonadIO m => MonadIO (IdentityT m) where liftIO f = lift (liftIO f) {-# INLINE liftIO #-} instance MonadFailure m => MonadFailure (IdentityT m) where type Failure (IdentityT m) = Failure m mFail = IdentityT . mFail instance MonadThrow m => MonadThrow (IdentityT m) where throw e = IdentityT (throw e) instance MonadCatch m => MonadCatch (IdentityT m) where catch (IdentityT m) c = IdentityT $ m `catch` (runIdentityT . c) foundation-0.0.23/Foundation/Monad/Base.hs0000644000000000000000000000077013415353646016520 0ustar0000000000000000module Foundation.Monad.Base ( Functor(..) , Applicative(..) , Monad(..) , MonadIO(..) , MonadFailure(..) , MonadThrow(..) , MonadCatch(..) , MonadTrans(..) , MonadFix(..) , IdentityT ) where import Basement.Compat.Base (Functor(..), Applicative(..), Monad(..)) import Basement.Monad import Foundation.Monad.MonadIO import Foundation.Monad.Exception import Foundation.Monad.Transformer import Foundation.Monad.Identity import Control.Monad.Fix (MonadFix(..)) foundation-0.0.23/Foundation/Random/Class.hs0000644000000000000000000000166013415353646017074 0ustar0000000000000000module Foundation.Random.Class ( MonadRandom(..) ) where import Data.Proxy import Basement.Imports import Foundation.System.Entropy import qualified Basement.UArray as A -- | A monad constraint that allows to generate random bytes class (Functor m, Applicative m, Monad m) => MonadRandom m where getRandomBytes :: CountOf Word8 -> m (UArray Word8) getRandomWord64 :: m Word64 getRandomF32 :: m Float getRandomF64 :: m Double instance MonadRandom IO where getRandomBytes = getEntropy getRandomWord64 = flip A.index 0 . A.unsafeRecast <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) getRandomF32 = flip A.index 0 . A.unsafeRecast <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) getRandomF64 = flip A.index 0 . A.unsafeRecast <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) foundation-0.0.23/Foundation/Random/DRG.hs0000644000000000000000000000430513415353646016442 0ustar0000000000000000module Foundation.Random.DRG ( RandomGen(..) , MonadRandomState(..) , withRandomGenerator ) where import Basement.Imports import Foundation.Random.Class -- | A Deterministic Random Generator (DRG) class class RandomGen gen where -- | 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 :: CountOf Word8 -> gen -> (UArray Word8, gen) -- | Generate a Word64 from a DRG randomGenerateWord64 :: gen -> (Word64, gen) randomGenerateF32 :: gen -> (Float, gen) randomGenerateF64 :: gen -> (Double, gen) -- | A simple Monad class very similar to a State Monad -- with the state being a RandomGenerator. newtype MonadRandomState gen a = MonadRandomState { runRandomState :: gen -> (a, gen) } instance Functor (MonadRandomState gen) where fmap f m = MonadRandomState $ \g1 -> let (a, g2) = runRandomState m g1 in (f a, g2) instance Applicative (MonadRandomState gen) where pure a = MonadRandomState $ \g -> (a, g) (<*>) fm m = MonadRandomState $ \g1 -> let (f, g2) = runRandomState fm g1 (a, g3) = runRandomState m g2 in (f a, g3) instance Monad (MonadRandomState gen) where return a = MonadRandomState $ \g -> (a, g) (>>=) m1 m2 = MonadRandomState $ \g1 -> let (a, g2) = runRandomState m1 g1 in runRandomState (m2 a) g2 instance RandomGen gen => MonadRandom (MonadRandomState gen) where getRandomBytes n = MonadRandomState (randomGenerate n) getRandomWord64 = MonadRandomState randomGenerateWord64 getRandomF32 = MonadRandomState randomGenerateF32 getRandomF64 = MonadRandomState randomGenerateF64 -- | Run a pure computation with a Random Generator in the 'MonadRandomState' withRandomGenerator :: RandomGen gen => gen -> MonadRandomState gen a -> (a, gen) withRandomGenerator gen m = runRandomState m gen foundation-0.0.23/Foundation/Random/ChaChaDRG.hs0000644000000000000000000000741013415353646017472 0ustar0000000000000000module Foundation.Random.ChaChaDRG ( State(..) , keySize ) where import Foundation.Class.Storable (peek) import Basement.Imports import Basement.Types.OffsetSize import Basement.Monad import Foundation.Random.Class import Foundation.Random.DRG import qualified Basement.UArray as A import qualified Basement.UArray.Mutable as A import GHC.ST import qualified Foreign.Marshal.Alloc (alloca) -- | RNG based on ChaCha core. -- -- The algorithm is identical to the arc4random found in recent BSDs, -- namely a ChaCha core provide 64 bytes of random from 32 bytes of -- key. newtype State = State (UArray Word8) instance RandomGen State where randomNew = State <$> getRandomBytes keySize randomNewFrom bs | A.length bs == keySize = Just $ State bs | otherwise = Nothing randomGenerate = generate randomGenerateWord64 = generateWord64 randomGenerateF32 = generateF32 randomGenerateF64 = generateF64 keySize :: CountOf Word8 keySize = 32 generate :: CountOf Word8 -> State -> (UArray Word8, State) generate n (State key) = runST $ do dst <- A.newPinned n newKey <- A.newPinned keySize A.withMutablePtr dst $ \dstP -> A.withMutablePtr newKey $ \newKeyP -> A.withPtr key $ \keyP -> do _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP n return () (,) <$> A.unsafeFreeze dst <*> (State <$> A.unsafeFreeze newKey) generateWord64 :: State -> (Word64, State) generateWord64 (State key) = runST $ unsafePrimFromIO $ Foreign.Marshal.Alloc.alloca $ \dst -> do newKey <- A.newPinned keySize A.withMutablePtr newKey $ \newKeyP -> A.withPtr key $ \keyP -> c_rngv1_generate_word64 newKeyP dst keyP *> return () (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey) generateF32 :: State -> (Float, State) generateF32 (State key) = runST $ unsafePrimFromIO $ Foreign.Marshal.Alloc.alloca $ \dst -> do newKey <- A.newPinned keySize A.withMutablePtr newKey $ \newKeyP -> A.withPtr key $ \keyP -> c_rngv1_generate_f32 newKeyP dst keyP *> return () (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey) generateF64 :: State -> (Double, State) generateF64 (State key) = runST $ unsafePrimFromIO $ Foreign.Marshal.Alloc.alloca $ \dst -> do newKey <- A.newPinned keySize A.withMutablePtr newKey $ \newKeyP -> A.withPtr key $ \keyP -> c_rngv1_generate_f64 newKeyP dst keyP *> return () (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey) -- return 0 on success, !0 for failure foreign import ccall unsafe "foundation_rngV1_generate" c_rngv1_generate :: Ptr Word8 -- new key -> Ptr Word8 -- destination -> Ptr Word8 -- current key -> CountOf Word8 -- number of bytes to generate -> IO Word32 foreign import ccall unsafe "foundation_rngV1_generate_word64" c_rngv1_generate_word64 :: Ptr Word8 -- new key -> Ptr Word64 -- destination -> Ptr Word8 -- current key -> IO Word32 foreign import ccall unsafe "foundation_rngV1_generate_f32" c_rngv1_generate_f32 :: Ptr Word8 -- new key -> Ptr Float -- destination -> Ptr Word8 -- current key -> IO Word32 foreign import ccall unsafe "foundation_rngV1_generate_f64" c_rngv1_generate_f64 :: Ptr Word8 -- new key -> Ptr Double -- destination -> Ptr Word8 -- current key -> IO Word32 foundation-0.0.23/Foundation/Random/XorShift.hs0000644000000000000000000000470613415353646017601 0ustar0000000000000000-- | -- Module : Foundation.Random.XorShift -- License : BSD-style -- -- XorShift variant: Xoroshiro128+ -- -- -- C implementation at: -- -- {-# LANGUAGE MagicHash #-} module Foundation.Random.XorShift ( State , initialize , next , nextList , nextDouble ) where import Basement.Imports import Basement.PrimType import Basement.Types.OffsetSize import Foundation.Numerical import Foundation.Bits import Foundation.Random.Class import Foundation.Random.DRG import Basement.Compat.Bifunctor import Basement.Compat.ExtList (reverse) import qualified Basement.UArray as A import qualified Prelude import GHC.Prim import GHC.Float -- | State of Xoroshiro128 plus data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 instance RandomGen State where randomNew = initialize <$> getRandomWord64 <*> getRandomWord64 randomNewFrom bs | A.length bs == 16 = let bs64 = A.recast bs in Just $ State (A.index bs64 0) (A.index bs64 1) | otherwise = Nothing randomGenerate = generate randomGenerateWord64 = next randomGenerateF32 = nextFloat randomGenerateF64 = nextDouble initialize :: Word64 -> Word64 -> State initialize s0 s1 = State s0 s1 generate :: CountOf Word8 -> State -> (UArray Word8, State) generate c st = first (A.take c . A.unsafeRecast . fromList) $ nextList c64 st where c64 = sizeRecast c' c' = countOfRoundUp 8 c next :: State -> (Word64, State) next (State s0 s1prev) = (s0 + s1prev, State s0' s1') where !s1 = s0 `xor` s1prev s0' = (s0 `rotateL` 55) `xor` s1 `xor` (s1 .<<. 14) s1' = (s1 `rotateL` 36) nextList :: CountOf Word64 -> State -> ([Word64], State) nextList c state = loop [] state 0 where loop acc st o | o .==# c = (reverse acc, st) | otherwise = let (w, st') = next st in loop (w:acc) st' (o+1) nextFloat :: State -> (Float, State) nextFloat = first dToF . nextDouble where dToF (D# d) = F# (double2Float# d) nextDouble :: State -> (Double, State) nextDouble !st = (d' - 1.0 , st') where !(w, st') = next st upperMask = 0x3FF0000000000000 lowerMask = 0x000FFFFFFFFFFFFF d' :: Double d' = Prelude.fromIntegral d d = upperMask .|. (w .&. lowerMask) foundation-0.0.23/Foundation/Array/Chunked/Unboxed.hs0000644000000000000000000003030513415353646020650 0ustar0000000000000000-- | -- Module : Foundation.Array.Chunked.Unboxed -- License : BSD-style -- Maintainer : Alfredo Di Napoli -- Stability : experimental -- Portability : portable -- -- Simple array-of-arrays abstraction -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Foundation.Array.Chunked.Unboxed ( ChunkedUArray ) where import Data.Typeable import Control.Arrow ((***)) import Basement.BoxedArray (Array) import qualified Basement.BoxedArray as A import Basement.Exception import Basement.UArray (UArray) import qualified Basement.UArray as U import Basement.Compat.Bifunctor import Basement.Compat.Semigroup import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.PrimType import GHC.ST import Foundation.Numerical import Foundation.Primitive import qualified Foundation.Collection as C newtype ChunkedUArray ty = ChunkedUArray (Array (UArray ty)) deriving (Show, Ord, Typeable) instance PrimType ty => Eq (ChunkedUArray ty) where (==) = equal instance NormalForm (ChunkedUArray ty) where toNormalForm (ChunkedUArray spine) = toNormalForm spine instance Semigroup (ChunkedUArray a) where (<>) = append instance Monoid (ChunkedUArray a) where mempty = empty mappend = append mconcat = concat type instance C.Element (ChunkedUArray ty) = ty instance PrimType ty => IsList (ChunkedUArray ty) where type Item (ChunkedUArray ty) = ty fromList = vFromList toList = vToList instance PrimType ty => C.Foldable (ChunkedUArray ty) where foldl' = foldl' foldr = foldr -- Use the default foldr' instance instance PrimType ty => C.Collection (ChunkedUArray ty) where null = null length = length elem = elem minimum = minimum maximum = maximum all p (ChunkedUArray cua) = A.all (U.all p) cua any p (ChunkedUArray cua) = A.any (U.any p) cua instance PrimType ty => C.Sequential (ChunkedUArray ty) where take = take drop = drop splitAt = splitAt revTake = revTake revDrop = revDrop splitOn = splitOn break = break breakEnd = breakEnd intersperse = intersperse filter = filter reverse = reverse unsnoc = unsnoc uncons = uncons snoc = snoc cons = cons find = find sortBy = sortBy singleton = fromList . (:[]) replicate n = fromList . C.replicate n instance PrimType ty => C.IndexedCollection (ChunkedUArray ty) where (!) l n | isOutOfBound n (length l) = Nothing | otherwise = Just $ index l n findIndex predicate c = loop 0 where !len = length c loop i | i .==# len = Nothing | otherwise = if predicate (unsafeIndex c i) then Just i else Nothing empty :: ChunkedUArray ty empty = ChunkedUArray A.empty append :: ChunkedUArray ty -> ChunkedUArray ty -> ChunkedUArray ty append (ChunkedUArray a1) (ChunkedUArray a2) = ChunkedUArray (mappend a1 a2) concat :: [ChunkedUArray ty] -> ChunkedUArray ty concat x = ChunkedUArray (mconcat $ fmap (\(ChunkedUArray spine) -> spine) x) vFromList :: PrimType ty => [ty] -> ChunkedUArray ty vFromList l = ChunkedUArray $ A.singleton $ fromList l vToList :: PrimType ty => ChunkedUArray ty -> [ty] vToList (ChunkedUArray a) = mconcat $ toList $ toList <$> a null :: PrimType ty => ChunkedUArray ty -> Bool null (ChunkedUArray array) = C.null array || allNulls 0 where !len = A.length array allNulls !idx | idx .==# len = True | otherwise = C.null (array `A.unsafeIndex` idx) && allNulls (idx + 1) -- | Returns the length of this `ChunkedUArray`, by summing each inner length. -- Complexity: O(n) where `n` is the number of chunks, as U.length u is O(1). length :: PrimType ty => ChunkedUArray ty -> CountOf ty length (ChunkedUArray array) = C.foldl' (\acc l -> acc + U.length l) 0 array -- | Returns `True` if the given element is contained in the `ChunkedUArray`. -- Complexity: O(n) where `n` is the number of chunks, as U.length u is O(1). elem :: PrimType ty => ty -> ChunkedUArray ty -> Bool elem el (ChunkedUArray array) = loop 0 where !len = A.length array loop i | i .==# len = False | otherwise = case C.elem el (A.unsafeIndex array i) of True -> True False -> loop (i+1) -- | Fold a `ChunkedUArray' leftwards strictly. Implemented internally using a double -- fold on the nested Array structure. Other folds implemented analogously. foldl' :: PrimType ty => (a -> ty -> a) -> a -> ChunkedUArray ty -> a foldl' f initialAcc (ChunkedUArray cua) = A.foldl' (U.foldl' f) initialAcc cua foldr :: PrimType ty => (ty -> a -> a) -> a -> ChunkedUArray ty -> a foldr f initialAcc (ChunkedUArray cua) = A.foldr (flip $ U.foldr f) initialAcc cua minimum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty minimum cua = foldl' min (unsafeIndex cua' 0) (drop 1 cua') where cua' = C.getNonEmpty cua maximum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty maximum cua = foldl' max (unsafeIndex cua' 0) (drop 1 cua') where cua' = C.getNonEmpty cua -- | Equality between `ChunkedUArray`. -- This function is fiddly to write as is not enough to compare for -- equality the inner `UArray`(s), we need an element-by-element -- comparison. equal :: PrimType ty => ChunkedUArray ty -> ChunkedUArray ty -> Bool equal ca1 ca2 = len1 == len2 && go 0 where len1 = length ca1 len2 = length ca2 go !x | x .==# len1 = True | otherwise = (ca1 `unsafeIndex` x == ca2 `unsafeIndex` x) && go (x + 1) -- given an offset express in element of ty, return the offset in array in the spine, -- plus the relative offset in element on this array findPos :: PrimType ty => Offset ty -> ChunkedUArray ty -> Maybe (Offset (UArray ty), Offset ty) findPos absOfs (ChunkedUArray array) | A.null array = Nothing | otherwise = loop absOfs 0 where !len = A.length array loop relOfs outerI | outerI .==# len = Nothing -- haven't found what to do | relOfs == 0 = Just (outerI, 0) | otherwise = let !innera = A.unsafeIndex array outerI !innerLen = U.length innera in case removeArraySize relOfs innerLen of Nothing -> Just (outerI, relOfs) Just relOfs' -> loop relOfs' (outerI + 1) splitChunk :: Offset (UArray ty) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) splitChunk ofs (ChunkedUArray c) = (ChunkedUArray *** ChunkedUArray) $ A.splitAt (offsetAsSize ofs) c take :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty take n c@(ChunkedUArray spine) | n <= 0 = empty | otherwise = case findPos (sizeAsOffset n) c of Nothing -> c Just (ofs, 0) -> ChunkedUArray (A.take (offsetAsSize ofs) spine) Just (ofs, r) -> let uarr = A.unsafeIndex spine ofs in ChunkedUArray (A.take (offsetAsSize ofs) spine `A.snoc` U.take (offsetAsSize r) uarr) drop :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty drop n c@(ChunkedUArray spine) | n <= 0 = c | otherwise = case findPos (sizeAsOffset n) c of Nothing -> empty Just (ofs, 0) -> ChunkedUArray (A.drop (offsetAsSize ofs) spine) Just (ofs, r) -> let uarr = A.unsafeIndex spine ofs in ChunkedUArray (U.drop (offsetAsSize r) uarr `A.cons` A.drop (offsetAsSize ofs+1) spine) splitAt :: PrimType ty => CountOf ty -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) splitAt n c@(ChunkedUArray spine) | n <= 0 = (empty, c) | otherwise = case findPos (sizeAsOffset n) c of Nothing -> (c, empty) Just (ofs, 0) -> splitChunk ofs c Just (ofs, offsetAsSize -> r) -> let uarr = A.unsafeIndex spine ofs in ( ChunkedUArray (A.take (offsetAsSize ofs) spine `A.snoc` U.take r uarr) , ChunkedUArray (U.drop r uarr `A.cons` A.drop (offsetAsSize ofs+1) spine) ) revTake :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty revTake n c = case length c - n of Nothing -> c Just elems -> drop elems c revDrop :: PrimType ty => CountOf ty -> ChunkedUArray ty -> ChunkedUArray ty revDrop n c = case length c - n of Nothing -> empty Just keepElems -> take keepElems c -- TODO: Improve implementation. splitOn :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> [ChunkedUArray ty] splitOn p = fmap fromList . C.splitOn p . toList -- TODO: Improve implementation. break :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) break p = bimap fromList fromList . C.break p . toList -- TODO: Improve implementation. breakEnd :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> (ChunkedUArray ty, ChunkedUArray ty) breakEnd p = bimap fromList fromList . C.breakEnd p . toList -- TODO: Improve implementation. intersperse :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty intersperse el = fromList . C.intersperse el . toList -- TODO: Improve implementation. reverse :: PrimType ty => ChunkedUArray ty -> ChunkedUArray ty reverse = fromList . C.reverse . toList -- TODO: Improve implementation. filter :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> ChunkedUArray ty filter p = fromList . C.filter p . toList -- TODO: Improve implementation. unsnoc :: PrimType ty => ChunkedUArray ty -> Maybe (ChunkedUArray ty, ty) unsnoc v = first fromList <$> (C.unsnoc $ toList v) -- TODO: Improve implementation. uncons :: PrimType ty => ChunkedUArray ty -> Maybe (ty, ChunkedUArray ty) uncons v = second fromList <$> (C.uncons $ toList v) cons :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty cons el (ChunkedUArray inner) = ChunkedUArray $ runST $ do let newLen = C.length inner + 1 newArray <- A.new newLen let single = fromList [el] A.unsafeWrite newArray 0 single A.unsafeCopyAtRO newArray (Offset 1) inner (Offset 0) (C.length inner) A.unsafeFreeze newArray snoc :: PrimType ty => ChunkedUArray ty -> ty -> ChunkedUArray ty snoc (ChunkedUArray spine) el = ChunkedUArray $ runST $ do newArray <- A.new (A.length spine + 1) let single = U.singleton el A.unsafeCopyAtRO newArray (Offset 0) spine (Offset 0) (C.length spine) A.unsafeWrite newArray (sizeAsOffset $ A.length spine) single A.unsafeFreeze newArray -- TODO optimise find :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> Maybe ty find fn v = loop 0 where len = length v loop !idx | idx .==# len = Nothing | otherwise = let currentElem = v `unsafeIndex` idx in case fn currentElem of True -> Just currentElem False -> loop (idx + 1) -- TODO: Improve implementation. sortBy :: PrimType ty => (ty -> ty -> Ordering) -> ChunkedUArray ty -> ChunkedUArray ty sortBy p = fromList . C.sortBy p . toList index :: PrimType ty => ChunkedUArray ty -> Offset ty -> ty index array n | isOutOfBound n len = outOfBound OOB_Index n len | otherwise = unsafeIndex array n where len = length array {-# INLINE index #-} unsafeIndex :: PrimType ty => ChunkedUArray ty -> Offset ty -> ty unsafeIndex (ChunkedUArray array) idx = go (A.unsafeIndex array 0) 0 idx where go u globalIndex 0 = case C.null u of -- Skip empty chunks. True -> go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) 0 False -> U.unsafeIndex u 0 go u !globalIndex !i -- Skip empty chunks. | C.null u = go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i | otherwise = case removeArraySize i (U.length u) of Just i' -> go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i' Nothing -> U.unsafeIndex u i {-# INLINE unsafeIndex #-} removeArraySize :: Offset ty -> CountOf ty -> Maybe (Offset ty) removeArraySize (Offset ty) (CountOf s) | ty >= s = Just (Offset (ty - s)) | otherwise = Nothing foundation-0.0.23/Foundation/Array/Bitmap.hs0000644000000000000000000003256013415353646017104 0ustar0000000000000000-- | -- Module : Foundation.Array.Bitmap -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- A simple abstraction to a set of Bits (Bitmap) -- -- Largely a placeholder for a more performant implementation, -- most operation goes through the List representation (e.g. [Bool]) -- to conduct even the most trivial operation, leading to a lots of -- unnecessary churn. -- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} module Foundation.Array.Bitmap ( Bitmap , MutableBitmap , empty , append , concat , unsafeIndex , index , read , unsafeRead , write , unsafeWrite , snoc , cons ) where import Basement.UArray (UArray) import qualified Basement.UArray as A import Basement.UArray.Mutable (MUArray) import Basement.Compat.Bifunctor (first, second, bimap) import Basement.Compat.Semigroup import Basement.Exception import Basement.Compat.Base import Basement.Types.OffsetSize import Basement.Monad import qualified Foundation.Collection as C import Foundation.Numerical import Data.Bits import Foundation.Bits import GHC.ST import qualified Data.List data Bitmap = Bitmap (CountOf Bool) (UArray Word32) deriving (Typeable) data MutableBitmap st = MutableBitmap (CountOf Bool) (MUArray Word32 st) bitsPerTy :: Int bitsPerTy = 32 shiftPerTy :: Int shiftPerTy = 5 maskPerTy :: Int maskPerTy = 0x1f instance Show Bitmap where show v = show (toList v) instance Eq Bitmap where (==) = equal instance Ord Bitmap where compare = vCompare instance Semigroup Bitmap where (<>) = append instance Monoid Bitmap where mempty = empty mappend = append mconcat = concat type instance C.Element Bitmap = Bool instance IsList Bitmap where type Item Bitmap = Bool fromList = vFromList toList = vToList instance C.InnerFunctor Bitmap where imap = map instance C.Foldable Bitmap where foldr = foldr foldl' = foldl' foldr' = foldr' instance C.Collection Bitmap where null = null length = length elem e = Data.List.elem e . toList maximum = any id . C.getNonEmpty minimum = all id . C.getNonEmpty all = all any = any instance C.Sequential Bitmap where take = take drop = drop splitAt = splitAt revTake n = unoptimised (C.revTake n) revDrop n = unoptimised (C.revDrop n) splitOn = splitOn break = break breakEnd = breakEnd span = span filter = filter reverse = reverse snoc = snoc cons = cons unsnoc = unsnoc uncons = uncons intersperse = intersperse find = find sortBy = sortBy singleton = fromList . (:[]) replicate n = fromList . C.replicate n instance C.IndexedCollection Bitmap where (!) l n | isOutOfBound n (length l) = Nothing | otherwise = Just $ index l n findIndex predicate c = loop 0 where !len = length c loop i | i .==# len = Nothing | predicate (unsafeIndex c i) = Just i | otherwise = Nothing instance C.MutableCollection MutableBitmap where type MutableFreezed MutableBitmap = Bitmap type MutableKey MutableBitmap = Offset Bool type MutableValue MutableBitmap = Bool thaw = thaw freeze = freeze unsafeThaw = unsafeThaw unsafeFreeze = unsafeFreeze mutNew = new mutUnsafeWrite = unsafeWrite mutUnsafeRead = unsafeRead mutWrite = write mutRead = read bitmapIndex :: Offset Bool -> (Offset Word32, Int) bitmapIndex (Offset !i) = (Offset (i .>>. shiftPerTy), i .&. maskPerTy) {-# INLINE bitmapIndex #-} -- return the index in word32 quantity and mask to a bit in a bitmap {- bitmapAddr :: Int -> (# Int , Word #) bitmapAddr !i = (# idx, mask #) where (!idx, !bitIdx) = bitmapIndex i !mask = case bitIdx of 0 -> 0x1 1 -> 0x2 2 -> 0x4 3 -> 0x8 4 -> 0x10 5 -> 0x20 6 -> 0x40 7 -> 0x80 8 -> 0x100 9 -> 0x200 10 -> 0x400 11 -> 0x800 12 -> 0x1000 13 -> 0x2000 14 -> 0x4000 15 -> 0x8000 16 -> 0x10000 17 -> 0x20000 18 -> 0x40000 19 -> 0x80000 20 -> 0x100000 21 -> 0x200000 22 -> 0x400000 23 -> 0x800000 24 -> 0x1000000 25 -> 0x2000000 26 -> 0x4000000 27 -> 0x8000000 28 -> 0x10000000 29 -> 0x20000000 30 -> 0x40000000 _ -> 0x80000000 -} thaw :: PrimMonad prim => Bitmap -> prim (MutableBitmap (PrimState prim)) thaw (Bitmap len ba) = MutableBitmap len `fmap` C.thaw ba freeze :: PrimMonad prim => MutableBitmap (PrimState prim) -> prim Bitmap freeze (MutableBitmap len mba) = Bitmap len `fmap` C.freeze mba unsafeThaw :: PrimMonad prim => Bitmap -> prim (MutableBitmap (PrimState prim)) unsafeThaw (Bitmap len ba) = MutableBitmap len `fmap` C.unsafeThaw ba unsafeFreeze :: PrimMonad prim => MutableBitmap (PrimState prim) -> prim Bitmap unsafeFreeze (MutableBitmap len mba) = Bitmap len `fmap` C.unsafeFreeze mba unsafeWrite :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> Bool -> prim () unsafeWrite (MutableBitmap _ ma) i v = do let (idx, bitIdx) = bitmapIndex i w <- A.unsafeRead ma idx let w' = if v then setBit w bitIdx else clearBit w bitIdx A.unsafeWrite ma idx w' {-# INLINE unsafeWrite #-} unsafeRead :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> prim Bool unsafeRead (MutableBitmap _ ma) i = do let (idx, bitIdx) = bitmapIndex i flip testBit bitIdx `fmap` A.unsafeRead ma idx {-# INLINE unsafeRead #-} write :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> Bool -> prim () write mb n val | isOutOfBound n len = primOutOfBound OOB_Write n len | otherwise = unsafeWrite mb n val where len = mutableLength mb {-# INLINE write #-} read :: PrimMonad prim => MutableBitmap (PrimState prim) -> Offset Bool -> prim Bool read mb n | isOutOfBound n len = primOutOfBound OOB_Read n len | otherwise = unsafeRead mb n where len = mutableLength mb {-# INLINE read #-} -- | Return the element at a specific index from a Bitmap. -- -- If the index @n is out of bounds, an error is raised. index :: Bitmap -> Offset Bool -> Bool index bits n | isOutOfBound n len = outOfBound OOB_Index n len | otherwise = unsafeIndex bits n where len = length bits {-# INLINE index #-} -- | Return the element at a specific index from an array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values. -- use 'index' if unsure. unsafeIndex :: Bitmap -> Offset Bool -> Bool unsafeIndex (Bitmap _ ba) n = let (idx, bitIdx) = bitmapIndex n in testBit (A.unsafeIndex ba idx) bitIdx {-# INLINE unsafeIndex #-} ----------------------------------------------------------------------- -- higher level collection implementation ----------------------------------------------------------------------- length :: Bitmap -> CountOf Bool length (Bitmap sz _) = sz mutableLength :: MutableBitmap st -> CountOf Bool mutableLength (MutableBitmap sz _) = sz empty :: Bitmap empty = Bitmap 0 mempty new :: PrimMonad prim => CountOf Bool -> prim (MutableBitmap (PrimState prim)) new sz@(CountOf len) = MutableBitmap sz <$> A.new nbElements where nbElements :: CountOf Word32 nbElements = CountOf ((len `alignRoundUp` bitsPerTy) .>>. shiftPerTy) -- | make an array from a list of elements. vFromList :: [Bool] -> Bitmap vFromList allBools = runST $ do mbitmap <- new len loop mbitmap 0 allBools where loop mb _ [] = unsafeFreeze mb loop mb i (x:xs) = unsafeWrite mb i x >> loop mb (i+1) xs {- runST $ do mba <- A.new nbElements ba <- loop mba (0 :: Int) allBools pure (Bitmap len ba) where loop mba _ [] = A.unsafeFreeze mba loop mba i l = do let (l1, l2) = C.splitAt bitsPerTy l w = toPacked l1 A.unsafeWrite mba i w loop mba (i+1) l2 toPacked :: [Bool] -> Word32 toPacked l = C.foldl' (.|.) 0 $ Prelude.zipWith (\b w -> if b then (1 `shiftL` w) else 0) l (C.reverse [0..31]) -} len = C.length allBools -- | transform an array to a list. vToList :: Bitmap -> [Bool] vToList a = loop 0 where len = length a loop i | i .==# len = [] | otherwise = unsafeIndex a i : loop (i+1) -- | Check if two vectors are identical equal :: Bitmap -> Bitmap -> Bool equal a b | la /= lb = False | otherwise = loop 0 where !la = length a !lb = length b loop n | n .==# la = True | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1) -- | Compare 2 vectors vCompare :: Bitmap -> Bitmap -> Ordering vCompare a b = loop 0 where !la = length a !lb = length b loop n | n .==# la = if la == lb then EQ else LT | n .==# lb = GT | otherwise = case unsafeIndex a n `compare` unsafeIndex b n of EQ -> loop (n+1) r -> r -- | Append 2 arrays together by creating a new bigger array -- -- TODO completely non optimized append :: Bitmap -> Bitmap -> Bitmap append a b = fromList $ toList a `mappend` toList b -- TODO completely non optimized concat :: [Bitmap] -> Bitmap concat l = fromList $ mconcat $ fmap toList l null :: Bitmap -> Bool null (Bitmap nbBits _) = nbBits == 0 take :: CountOf Bool -> Bitmap -> Bitmap take nbElems bits@(Bitmap nbBits ba) | nbElems <= 0 = empty | nbElems >= nbBits = bits | otherwise = Bitmap nbElems ba -- TODO : although it work right now, take on the underlaying ba too drop :: CountOf Bool -> Bitmap -> Bitmap drop nbElems bits@(Bitmap nbBits _) | nbElems <= 0 = bits | nbElems >= nbBits = empty | otherwise = unoptimised (C.drop nbElems) bits -- TODO: decide if we have drop easy by having a bit offset in the data structure -- or if we need to shift stuff around making all the indexing slighlty more complicated splitAt :: CountOf Bool -> Bitmap -> (Bitmap, Bitmap) splitAt n v = (take n v, drop n v) -- unoptimised splitOn :: (Bool -> Bool) -> Bitmap -> [Bitmap] splitOn f bits = fmap fromList $ C.splitOn f $ toList bits -- unoptimised break :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) break predicate v = findBreak 0 where len = length v findBreak i | i .==# len = (v, empty) | otherwise = if predicate (unsafeIndex v i) then splitAt (offsetAsSize i) v else findBreak (i+1) breakEnd :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) breakEnd predicate = bimap fromList fromList . C.breakEnd predicate . toList span :: (Bool -> Bool) -> Bitmap -> (Bitmap, Bitmap) span p = break (not . p) map :: (Bool -> Bool) -> Bitmap -> Bitmap map f bits = unoptimised (fmap f) bits --mapIndex :: (Int -> Bool -> Bool) -> Bitmap -> Bitmap --mapIndex f Bitmap = cons :: Bool -> Bitmap -> Bitmap cons v l = unoptimised (C.cons v) l snoc :: Bitmap -> Bool -> Bitmap snoc l v = unoptimised (flip C.snoc v) l -- unoptimised uncons :: Bitmap -> Maybe (Bool, Bitmap) uncons b = fmap (second fromList) $ C.uncons $ toList b -- unoptimised unsnoc :: Bitmap -> Maybe (Bitmap, Bool) unsnoc b = fmap (first fromList) $ C.unsnoc $ toList b intersperse :: Bool -> Bitmap -> Bitmap intersperse b = unoptimised (C.intersperse b) find :: (Bool -> Bool) -> Bitmap -> Maybe Bool find predicate vec = loop 0 where !len = length vec loop i | i .==# len = Nothing | otherwise = let e = unsafeIndex vec i in if predicate e then Just e else loop (i+1) sortBy :: (Bool -> Bool -> Ordering) -> Bitmap -> Bitmap sortBy by bits = unoptimised (C.sortBy by) bits filter :: (Bool -> Bool) -> Bitmap -> Bitmap filter predicate vec = unoptimised (Data.List.filter predicate) vec reverse :: Bitmap -> Bitmap reverse bits = unoptimised C.reverse bits foldr :: (Bool -> a -> a) -> a -> Bitmap -> a foldr f initialAcc vec = loop 0 where len = length vec loop i | i .==# len = initialAcc | otherwise = unsafeIndex vec i `f` loop (i+1) foldr' :: (Bool -> a -> a) -> a -> Bitmap -> a foldr' = foldr foldl' :: (a -> Bool -> a) -> a -> Bitmap -> a foldl' f initialAcc vec = loop 0 initialAcc where len = length vec loop i !acc | i .==# len = acc | otherwise = loop (i+1) (f acc (unsafeIndex vec i)) all :: (Bool -> Bool) -> Bitmap -> Bool all p bm = loop 0 where len = length bm loop !i | i .==# len = True | not $ p (unsafeIndex bm i) = False | otherwise = loop (i + 1) any :: (Bool -> Bool) -> Bitmap -> Bool any p bm = loop 0 where len = length bm loop !i | i .==# len = False | p (unsafeIndex bm i) = True | otherwise = loop (i + 1) unoptimised :: ([Bool] -> [Bool]) -> Bitmap -> Bitmap unoptimised f = vFromList . f . vToList foundation-0.0.23/Foundation/Foreign/Alloc.hs0000644000000000000000000000051013415353646017223 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Foundation.Foreign.Alloc ( allocaBytes ) where import qualified Foreign.Marshal.Alloc as A (allocaBytes) import Basement.Imports import Basement.Types.OffsetSize allocaBytes :: CountOf Word8 -> (Ptr a -> IO b) -> IO b allocaBytes (CountOf i) f = A.allocaBytes i f foundation-0.0.23/Foundation/Foreign/MemoryMap.hs0000644000000000000000000000055413415353646020107 0ustar0000000000000000{-# LANGUAGE CPP #-} module Foundation.Foreign.MemoryMap ( fileMapRead , FileMapping(..) , fileMappingToFinalPtr ) where import Foundation.Foreign.MemoryMap.Types #ifdef mingw32_HOST_OS import Foundation.Foreign.MemoryMap.Windows #else import Foundation.Foreign.MemoryMap.Posix #endif {- fileMap :: Fd -> Int -> IO FileMap fileMap = undefined -} foundation-0.0.23/Foundation/Foreign/MemoryMap/Types.hs0000644000000000000000000000177513415353646021221 0ustar0000000000000000-- | -- Module : Foundation.Foreign.MemoryMap.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- module Foundation.Foreign.MemoryMap.Types ( FileMapping(..) , fileMappingToFinalPtr , FileMapReadF ) where import GHC.Ptr import Basement.FinalPtr import Basement.Types.OffsetSize import Basement.Compat.Base import Foundation.VFS (FilePath) -- | Contains all the information related to a file mapping, -- including the size and the finalizer function. data FileMapping = FileMapping { fileMappingPtr :: Ptr Word8 , fileMappingSize :: FileSize , fileMappingUnmap :: IO () } -- | From a file mapping, create a final ptr which will automatically -- unmap memory when the pointer is garbage. fileMappingToFinalPtr :: FileMapping -> IO (FinalPtr Word8) fileMappingToFinalPtr (FileMapping ptr _ finalizer) = toFinalPtr ptr (const finalizer) type FileMapReadF = FilePath -> IO FileMapping foundation-0.0.23/Foundation/Partial.hs0000644000000000000000000000410113415353646016174 0ustar0000000000000000-- | -- Module : Foundation.Partial -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Partial give a way to annotate your partial function with -- a simple wrapper, which can only evaluated using 'fromPartial' -- -- > fromPartial ( head [] ) -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Partial ( Partial , PartialError , partialError , partial , fromPartial , head , fromJust , fromLeft , fromRight ) where import Basement.Compat.Base import Basement.Compat.Identity -- | Partialiality wrapper. newtype Partial a = Partial (Identity a) deriving (Functor, Applicative, Monad) -- | An error related to the evaluation of a Partial value that failed. -- -- it contains the name of the function and the reason for failure data PartialError = PartialError [Char] [Char] deriving (Show,Eq,Typeable) instance Exception PartialError -- | Throw an asynchronous PartialError partialError :: [Char] -> [Char] -> a partialError lbl exp = throw (PartialError lbl exp) -- | Create a value that is partial. this can only be -- unwrap using the 'fromPartial' function partial :: a -> Partial a partial = pure -- | Dewrap a possible partial value fromPartial :: Partial a -> a fromPartial (Partial ida) = runIdentity ida -- | Partial function to get the head of a list head :: [a] -> Partial a head l = partial $ case l of [] -> partialError "head" "empty list" x:_ -> x -- | Partial function to grab the value inside a Maybe fromJust :: Maybe a -> Partial a fromJust x = partial $ case x of Nothing -> partialError "fromJust" "Nothing" Just y -> y -- Grab the Right value of an Either fromRight :: Either a b -> Partial b fromRight x = partial $ case x of Left _ -> partialError "fromRight" "Left" Right a -> a -- Grab the Left value of an Either fromLeft :: Either a b -> Partial a fromLeft x = partial $ case x of Right _ -> partialError "fromLeft" "Right" Left a -> a foundation-0.0.23/Foundation/System/Entropy/Common.hs0000644000000000000000000000075713415353646020771 0ustar0000000000000000-- | -- Module : Foundation.System.Entropy.Common -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : portable -- -- Common part for vectors -- {-# LANGUAGE DeriveDataTypeable #-} module Foundation.System.Entropy.Common ( EntropySystemMissing(..) ) where import Basement.Compat.Base data EntropySystemMissing = EntropySystemMissing deriving (Show,Eq,Typeable) instance Exception EntropySystemMissing foundation-0.0.23/Foundation/System/Bindings/Network.hsc0000644000000000000000000000213313415353646021420 0ustar0000000000000000-- | -- Module : Foundation.System.Bindings.HostName -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : provisional -- Portability : portable -- {-# OPTIONS_HADDOCK hide #-} module Foundation.System.Bindings.Network ( -- * error getHErrno , herr_HostNotFound , herr_NoData , herr_NoRecovery , herr_TryAgain ) where import Basement.Compat.Base import Basement.Compat.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 foundation-0.0.23/Foundation/System/Bindings/Time.hsc0000644000000000000000000000675113415353646020677 0ustar0000000000000000-- | -- Module : Foundation.System.Bindings.Time -- Maintainer : Haskell foundation -- module Foundation.System.Bindings.Time where import Basement.Compat.Base import Basement.Compat.C.Types import Basement.Types.OffsetSize #include #include #include "foundation_system.h" type CClockId = CInt data CTimeSpec data CTimeVal data CTimeZone size_CTimeSpec :: CSize size_CTimeSpec = #const sizeof(struct timespec) ofs_CTimeSpec_Seconds :: Offset Word8 ofs_CTimeSpec_Seconds = Offset (#offset struct timespec, tv_sec) ofs_CTimeSpec_NanoSeconds :: Offset Word8 ofs_CTimeSpec_NanoSeconds = Offset (#offset struct timespec, tv_nsec) size_CTimeVal :: CSize size_CTimeVal = #const sizeof(struct timeval) size_CTimeZone :: CSize size_CTimeZone = #const sizeof(struct timezone) size_CTimeT :: CSize size_CTimeT = #const sizeof(time_t) ------------------------------------------------------------------------ #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK #define FOUNDATION_CLOCK_REALTIME 0 #define FOUNDATION_CLOCK_MONOTONIC 1 #define FOUNDATION_CLOCK_PROCESS_CPUTIME_ID 2 #define FOUNDATION_CLOCK_THREAD_CPUTIME_ID 3 #endif sysTime_CLOCK_REALTIME :: CClockId #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK sysTime_CLOCK_REALTIME = (#const FOUNDATION_CLOCK_REALTIME) #else sysTime_CLOCK_REALTIME = (#const CLOCK_REALTIME) #endif sysTime_CLOCK_MONOTONIC :: CClockId #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK sysTime_CLOCK_MONOTONIC = (#const FOUNDATION_CLOCK_MONOTONIC) #else sysTime_CLOCK_MONOTONIC = (#const CLOCK_MONOTONIC) #endif sysTime_CLOCK_PROCESS_CPUTIME_ID :: CClockId #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK sysTime_CLOCK_PROCESS_CPUTIME_ID = (#const FOUNDATION_CLOCK_PROCESS_CPUTIME_ID) #else sysTime_CLOCK_PROCESS_CPUTIME_ID = (#const CLOCK_PROCESS_CPUTIME_ID) #endif sysTime_CLOCK_THREAD_CPUTIME_ID :: CClockId #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK sysTime_CLOCK_THREAD_CPUTIME_ID = (#const FOUNDATION_CLOCK_THREAD_CPUTIME_ID) #else sysTime_CLOCK_THREAD_CPUTIME_ID = (#const CLOCK_THREAD_CPUTIME_ID) #endif #ifdef CLOCK_MONOTONIC_RAW sysTime_CLOCK_MONOTONIC_RAW :: CClockId sysTime_CLOCK_MONOTONIC_RAW = (#const CLOCK_MONOTONIC_RAW) #endif #ifdef CLOCK_REALTIME_COARSE sysTime_CLOCK_REALTIME_COARSE :: CClockId sysTime_CLOCK_REALTIME_COARSE = (#const CLOCK_REALTIME_COARSE) #endif #ifdef CLOCK_MONOTIC_COARSE sysTime_CLOCK_MONOTONIC_COARSE :: CClockId sysTime_CLOCK_MONOTONIC_COARSE = (#const CLOCK_MONOTONIC_COARSE) #endif #ifdef CLOCK_BOOTTIME sysTime_CLOCK_BOOTTIME :: CClockId sysTime_CLOCK_BOOTTIME = (#const CLOCK_BOOTTIME) #endif #ifdef CLOCK_REALTIME_ALARM sysTime_CLOCK_REALTIME_ALARM :: CClockId sysTime_CLOCK_REALTIME_ALARM = (#const CLOCK_REALTIME_ALARM) #endif #ifdef CLOCK_BOOTTIME_ALARM sysTime_CLOCK_BOOTTIME_ALARM :: CClockId sysTime_CLOCK_BOOTTIME_ALARM = (#const CLOCK_BOOTTIME_ALARM) #endif #ifdef CLOCK_TAI sysTime_CLOCK_TAI :: CClockId sysTime_CLOCK_TAI = (#const CLOCK_TAI) #endif #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK foreign import ccall unsafe "foundation_time_clock_getres" sysTimeClockGetRes :: CClockId -> Ptr CTimeSpec -> IO CInt foreign import ccall unsafe "foundation_time_clock_gettime" sysTimeClockGetTime :: CClockId -> Ptr CTimeSpec -> IO CInt #else foreign import ccall unsafe "clock_getres" sysTimeClockGetRes :: CClockId -> Ptr CTimeSpec -> IO CInt foreign import ccall unsafe "clock_gettime" sysTimeClockGetTime :: CClockId -> Ptr CTimeSpec -> IO CInt #endif foreign import ccall unsafe "gettimeofday" sysTimeGetTimeOfDay :: Ptr CTimeVal -> Ptr CTimeZone -> IO CInt foundation-0.0.23/Foundation/System/Bindings/Hs.hs0000644000000000000000000000041713415353646020201 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnliftedFFITypes #-} module Foundation.System.Bindings.Hs where import GHC.IO import Basement.Compat.C.Types foreign import ccall unsafe "HsBase.h __hscore_get_errno" sysHsCoreGetErrno :: IO CInt foundation-0.0.23/Foundation/Foreign/MemoryMap/Windows.hs0000644000000000000000000000175213415353646021542 0ustar0000000000000000module Foundation.Foreign.MemoryMap.Windows ( fileMapRead ) where import System.Win32.Mem import System.Win32.File import System.Win32.FileMapping import Control.Exception hiding (handle) import Basement.Compat.Base import Basement.Types.OffsetSize import Foundation.VFS import Foundation.Foreign.MemoryMap.Types fileMapRead :: FileMapReadF fileMapRead path = bracket doOpen closeHandle doMapping where doOpen = createFile (filePathToLString path) gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing doMapping handle = bracket (createFileMapping (Just handle) pAGE_READONLY 0 Nothing) closeHandle (getSizeAndMap handle) getSizeAndMap handle filemap = do fileInfo <- getFileInformationByHandle handle mask_ $ do ptr <- mapViewOfFile filemap fILE_MAP_READ 0 0 return $ FileMapping ptr (FileSize $ bhfiSize fileInfo) (unmapViewOfFile ptr) foundation-0.0.23/Foundation/System/Entropy/Windows.hs0000644000000000000000000000553713415353646021174 0ustar0000000000000000-- | -- Module : Foundation.System.Entropy.Windows -- License : BSD-style -- Maintainer : Foundation -- Stability : experimental -- Portability : Good -- -- some code originally from cryptonite and some from the entropy package -- Copyright (c) Thomas DuBuisson. -- {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} module Foundation.System.Entropy.Windows ( EntropyCtx , entropyOpen , entropyGather , entropyClose , entropyMaximumSize ) where import Data.Int (Int32) import Data.Word import Foreign.C.String (CString, withCString) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (toBool) import Foreign.Storable (peek) import System.Win32.Types (getLastError) import Control.Exception import Foundation.System.Entropy.Common import Basement.Compat.Base import qualified Prelude newtype EntropyCtx = EntropyCtx CryptCtx entropyOpen :: IO EntropyCtx entropyOpen = EntropyCtx <$> cryptAcquireCtx entropyGather :: EntropyCtx -> Ptr Word8 -> Int -> IO Bool entropyGather (EntropyCtx ctx) ptr n = cryptGenRandom ctx ptr n entropyClose :: EntropyCtx -> IO () entropyClose (EntropyCtx ctx) = cryptReleaseCtx ctx entropyMaximumSize :: Int entropyMaximumSize = 4096 type DWORD = Word32 type BOOL = Int32 type BYTE = Word8 #ifdef mingw32_HOST_OS #ifdef x86_64_HOST_ARCH # define WINDOWS_CCONV ccall type CryptCtx = Word64 #else # define WINDOWS_CCONV stdcall type CryptCtx = Word32 #endif #else # error Unknown windows platform #endif -- Declare the required CryptoAPI imports foreign import WINDOWS_CCONV unsafe "CryptAcquireContextA" c_cryptAcquireCtx :: Ptr CryptCtx -> CString -> CString -> DWORD -> DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "CryptGenRandom" c_cryptGenRandom :: CryptCtx -> DWORD -> Ptr BYTE -> IO BOOL foreign import WINDOWS_CCONV unsafe "CryptReleaseContext" c_cryptReleaseCtx :: CryptCtx -> DWORD -> IO BOOL -- Define the constants we need from WinCrypt.h msDefProv :: [Char] msDefProv = "Microsoft Base Cryptographic Provider v1.0" provRSAFull :: DWORD provRSAFull = 1 cryptVerifyContext :: DWORD cryptVerifyContext = 0xF0000000 cryptAcquireCtx :: IO CryptCtx cryptAcquireCtx = alloca $ \handlePtr -> withCString msDefProv $ \provName -> do r <- toBool `fmap` c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext if r then peek handlePtr else throwIO EntropySystemMissing cryptGenRandom :: CryptCtx -> Ptr Word8 -> Int -> IO Bool cryptGenRandom h buf n = toBool `fmap` c_cryptGenRandom h (Prelude.fromIntegral n) buf cryptReleaseCtx :: CryptCtx -> IO () cryptReleaseCtx h = do success <- toBool `fmap` c_cryptReleaseCtx h 0 if success then return () else do lastError <- getLastError fail $ "cryptReleaseCtx: error " <> show lastError foundation-0.0.23/Foundation/Foreign/MemoryMap/Posix.hsc0000644000000000000000000002055713415353646021361 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Foundation.Foreign.MemoryMap.Posix -- Copyright : (c) Vincent Hanquez 2014 -- License : BSD-style -- -- Maintainer : Vincent Hanquez -- Stability : provisional -- Portability : non-portable (requires POSIX) -- -- Functions defined by the POSIX standards for manipulating memory maps -- -- When a function that calls an underlying POSIX function fails, the errno -- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'. -- For a list of which errno codes may be generated, consult the POSIX -- documentation for the underlying function. -- ----------------------------------------------------------------------------- #include #include {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE CPP #-} module Foundation.Foreign.MemoryMap.Posix ( memoryMap , memoryUnmap , memoryAdvise , memoryLock , memoryUnlock , memoryProtect , memorySync -- * Flags types , MemoryMapFlag(..) , MemoryProtection(..) , MemoryAdvice(..) , MemorySyncFlag(..) -- * system page size , sysconfPageSize -- * High level , fileMapRead ) where import Basement.Compat.Base import Basement.Compat.C.Types import Basement.Types.OffsetSize import System.Posix.Types import Foreign.Ptr import Foreign.C.Error import Data.Bits import Foundation.Collection.Foldable import Foundation.VFS import qualified Prelude (fromIntegral) import Foundation.Foreign.MemoryMap.Types import Control.Exception import GHC.IO.FD import GHC.IO.IOMode import qualified GHC.IO.Device as IO foreign import ccall unsafe "mmap" c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) foreign import ccall unsafe "munmap" c_munmap :: Ptr a -> CSize -> IO CInt #if defined(POSIX_MADV_NORMAL) foreign import ccall unsafe "posix_madvise" c_madvise :: Ptr a -> CSize -> CInt -> IO CInt #else foreign import ccall unsafe "madvise" c_madvise :: Ptr a -> CSize -> CInt -> IO CInt #endif foreign import ccall unsafe "msync" c_msync :: Ptr a -> CSize -> CInt -> IO CInt foreign import ccall unsafe "mprotect" c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt #ifndef __HAIKU__ foreign import ccall unsafe "mlock" c_mlock :: Ptr a -> CSize -> IO CInt #else c_mlock :: Ptr a -> CSize -> IO CInt c_mlock _ _ = return (-1) #endif #ifndef __HAIKU__ foreign import ccall unsafe "munlock" c_munlock :: Ptr a -> CSize -> IO CInt #else c_munlock :: Ptr a -> CSize -> IO CInt c_munlock _ _ = return (-1) #endif foreign import ccall unsafe "sysconf" c_sysconf :: CInt -> CLong -- | Mapping flag data MemoryMapFlag = MemoryMapShared -- ^ memory changes are shared between process | MemoryMapPrivate -- ^ memory changes are private to process deriving (Show,Eq) -- | Memory protection data MemoryProtection = MemoryProtectionNone | MemoryProtectionRead | MemoryProtectionWrite | MemoryProtectionExecute deriving (Show,Eq) -- | Advice to put on memory. -- -- only define the posix one. data MemoryAdvice = MemoryAdviceNormal -- ^ no specific advice, the default. | MemoryAdviceRandom -- ^ Expect page references in random order. No readahead should occur. | MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively. | MemoryAdviceWillNeed -- ^ Expect access in the near future. Probably a good idea to readahead early | MemoryAdviceDontNeed -- ^ Do not expect access in the near future. deriving (Show,Eq) -- | Memory synchronization flags data MemorySyncFlag = MemorySyncAsync -- ^ perform asynchronous write. | MemorySyncSync -- ^ perform synchronous write. | MemorySyncInvalidate -- ^ invalidate cache data. deriving (Show,Eq) cvalueOfMemoryProts :: [MemoryProtection] -> CInt cvalueOfMemoryProts = foldl' (.|.) 0 . fmap toProt where toProt :: MemoryProtection -> CInt toProt MemoryProtectionNone = (#const PROT_NONE) toProt MemoryProtectionRead = (#const PROT_READ) toProt MemoryProtectionWrite = (#const PROT_WRITE) toProt MemoryProtectionExecute = (#const PROT_EXEC) cvalueOfMemorySync :: [MemorySyncFlag] -> CInt cvalueOfMemorySync = foldl' (.|.) 0 . fmap toSync where toSync MemorySyncAsync = (#const MS_ASYNC) toSync MemorySyncSync = (#const MS_SYNC) toSync MemorySyncInvalidate = (#const MS_INVALIDATE) -- | Map pages of memory. -- -- If fd is present, this memory will represent the file associated. -- Otherwise, the memory will be an anonymous mapping. -- -- use 'mmap' memoryMap :: Maybe (Ptr a) -- ^ The address to map to if MapFixed is used. -> CSize -- ^ The length of the mapping -> [MemoryProtection] -- ^ the memory protection associated with the mapping -> MemoryMapFlag -- ^ -> Maybe Fd -> COff -> IO (Ptr a) memoryMap initPtr sz prots flag mfd off = throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off) where m1ptr = nullPtr `plusPtr` (-1) fd = maybe (-1) (\(Fd v) -> v) mfd cprot = cvalueOfMemoryProts prots cflags = maybe cMapAnon (const 0) mfd .|. maybe 0 (const cMapFixed) initPtr .|. toMapFlag flag #ifdef __APPLE__ cMapAnon = (#const MAP_ANON) #else cMapAnon = (#const MAP_ANONYMOUS) #endif cMapFixed = (#const MAP_FIXED) toMapFlag MemoryMapShared = (#const MAP_SHARED) toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE) -- | Unmap pages of memory -- -- use 'munmap' memoryUnmap :: Ptr a -> CSize -> IO () memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz) -- | give advice to the operating system about use of memory -- -- call 'madvise' memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO () memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv) where cadv = toAdvice adv #if defined(POSIX_MADV_NORMAL) toAdvice MemoryAdviceNormal = (#const POSIX_MADV_NORMAL) toAdvice MemoryAdviceRandom = (#const POSIX_MADV_RANDOM) toAdvice MemoryAdviceSequential = (#const POSIX_MADV_SEQUENTIAL) toAdvice MemoryAdviceWillNeed = (#const POSIX_MADV_WILLNEED) toAdvice MemoryAdviceDontNeed = (#const POSIX_MADV_DONTNEED) #else toAdvice MemoryAdviceNormal = (#const MADV_NORMAL) toAdvice MemoryAdviceRandom = (#const MADV_RANDOM) toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL) toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED) toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED) #endif -- | lock a range of process address space -- -- call 'mlock' memoryLock :: Ptr a -> CSize -> IO () memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz) -- | unlock a range of process address space -- -- call 'munlock' memoryUnlock :: Ptr a -> CSize -> IO () memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz) -- | set protection of memory mapping -- -- call 'mprotect' memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO () memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot) where cprot = cvalueOfMemoryProts prots -- | memorySync synchronize memory with physical storage. -- -- On an anonymous mapping this function does not have any effect. -- call 'msync' memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO () memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags) where cflags = cvalueOfMemorySync flags -- | Return the operating system page size. -- -- call 'sysconf' sysconfPageSize :: Int sysconfPageSize = Prelude.fromIntegral $ c_sysconf (#const _SC_PAGESIZE) -------------------------------------------------------------------------------- fileSizeToCSize :: FileSize -> CSize fileSizeToCSize (FileSize sz) = Prelude.fromIntegral sz fileSizeFromInteger :: Integer -> FileSize fileSizeFromInteger = FileSize . Prelude.fromIntegral fileMapRead :: FileMapReadF fileMapRead fp = bracket (openFile (filePathToLString fp) ReadMode True) (IO.close . fst) $ \(fd,_) -> do sz <- fileSizeFromInteger `fmap` IO.getSize fd let csz = fileSizeToCSize sz p <- memoryMap Nothing csz [MemoryProtectionRead] MemoryMapPrivate (Just $ Fd $ fdFD fd) 0 return $ FileMapping p sz (memoryUnmap p csz) foundation-0.0.23/Foundation/System/Entropy/Unix.hs0000644000000000000000000000471613415353646020463 0ustar0000000000000000-- | -- Module : Foundation.System.Entropy.Unix -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : Good -- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ForeignFunctionInterface #-} module Foundation.System.Entropy.Unix ( EntropyCtx , entropyOpen , entropyGather , entropyClose , entropyMaximumSize ) where import Foreign.Ptr import Control.Exception as E import Control.Monad import System.IO import System.IO.Unsafe (unsafePerformIO) import Basement.Compat.Base import Basement.Compat.C.Types import Prelude (fromIntegral) import Foundation.System.Entropy.Common import Foundation.Numerical data EntropyCtx = EntropyCtx Handle | EntropySyscall entropyOpen :: IO EntropyCtx entropyOpen = do if supportSyscall then return EntropySyscall else do mh <- openDev "/dev/urandom" case mh of Nothing -> E.throwIO EntropySystemMissing Just h -> return $ EntropyCtx h -- | try to fill the ptr with the amount of data required. -- Return the number of bytes, or a negative number otherwise entropyGather :: EntropyCtx -> Ptr Word8 -> Int -> IO Bool entropyGather (EntropyCtx h) ptr n = gatherDevEntropy h ptr n entropyGather EntropySyscall ptr n = (==) 0 <$> c_sysrandom_linux ptr (fromIntegral n) entropyClose :: EntropyCtx -> IO () entropyClose (EntropyCtx h) = hClose h entropyClose EntropySyscall = return () entropyMaximumSize :: Int entropyMaximumSize = 4096 openDev :: [Char] -> IO (Maybe Handle) openDev filepath = (Just `fmap` openAndNoBuffering) `E.catch` \(_ :: IOException) -> return Nothing where openAndNoBuffering = do h <- openBinaryFile filepath ReadMode hSetBuffering h NoBuffering return h gatherDevEntropy :: Handle -> Ptr Word8 -> Int -> IO Bool gatherDevEntropy h ptr sz = loop ptr sz `E.catch` failOnException where loop _ 0 = return True loop p n = do r <- hGetBufSome h p n if r >= 0 then loop (p `plusPtr` r) (n - r) else return False failOnException :: E.IOException -> IO Bool failOnException _ = return False supportSyscall :: Bool supportSyscall = unsafePerformIO ((==) 0 <$> c_sysrandom_linux nullPtr 0) {-# NOINLINE supportSyscall #-} -- return 0 on success, !0 for failure foreign import ccall unsafe "foundation_sysrandom_linux" c_sysrandom_linux :: Ptr Word8 -> CSize -> IO Int foundation-0.0.23/cbits/foundation_random.c0000644000000000000000000001174713415353646017132 0ustar0000000000000000 #include #include #include #include #include #include "foundation_prim.h" #include "foundation_system.h" #include "foundation_bits.h" #if defined(FOUNDATION_SYSTEM_LINUX) #include #include #include #ifndef _GNU_SOURCE #define _GNU_SOURCE #endif #endif #include #if defined(FOUNDATION_SYSTEM_LINUX) && defined(SYS_getrandom) int foundation_sysrandom_linux(void *buf, size_t length) { unsigned int flags = 1; /* RANDOM=0x2, NONBLOCK=0x1 */ size_t i = 0; /* special case to detect availability */ if (length == 0) { int r = syscall(SYS_getrandom, buf, 0, flags); return (r == -1) ? -1 : 0; } while (i < length) { int r = syscall(SYS_getrandom, buf + i, length - i, flags); if (r <= 0) { if (errno != -EAGAIN) return -errno; } if (r > 0) i += r; } return 0; } #else int foundation_sysrandom_linux(void *buf, size_t length) { return -ENODEV; } #endif #define CHACHA_KEY_SIZE 32 #define CHACHA_NONCE_SIZE 16 #define CHACHA_OUTPUT_SIZE 64 #define CHACHA_KEY_SIZE32 8 #define CHACHA_NONCE_SIZE32 4 #define CHACHA_OUTPUT_SIZE32 16 #define QR(a,b,c,d) \ a += b; d = rol32(d ^ a,16); \ c += d; b = rol32(b ^ c,12); \ a += b; d = rol32(d ^ a, 8); \ c += d; b = rol32(b ^ c, 7); static void chacha_core(int rounds, uint8_t out8[CHACHA_OUTPUT_SIZE], const uint8_t key8[CHACHA_KEY_SIZE], const uint8_t nonce8[CHACHA_NONCE_SIZE]) { uint32_t x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15; int i; static const uint8_t sigma8[16] = "expand 32-byte k"; uint32_t *out = (uint32_t *) out8; uint32_t *key = (uint32_t *) key8; uint32_t *nonce = (uint32_t *) nonce8; uint32_t *sigma = (uint32_t *) sigma8; x0 = sigma[0]; x1 = sigma[1]; x2 = sigma[2]; x3 = sigma[3]; x4 = key[0] ; x5 = key[1] ; x6 = key[2] ; x7 = key[3] ; x8 = key[4] ; x9 = key[5] ; x10 = key[6] ; x11 = key[7] ; x12 = nonce[0]; x13 = nonce[1]; x14 = nonce[2]; x15 = nonce[3]; for (i = rounds; i > 0; i -= 2) { QR(x0, x4, x8, x12); QR(x1, x5, x9, x13); QR(x2, x6, x10, x14); QR(x3, x7, x11, x15); QR(x0, x5, x10, x15); QR(x1, x6, x11, x12); QR(x2, x7, x8, x13); QR(x3, x4, x9, x14); } x0 += sigma[0]; x1 += sigma[1]; x2 += sigma[2]; x3 += sigma[3]; x4 += key[0] ; x5 += key[1] ; x6 += key[2] ; x7 += key[3] ; x8 += key[4] ; x9 += key[5] ; x10 += key[6] ; x11 += key[7] ; x12 += nonce[0]; x13 += nonce[1]; x14 += nonce[2]; x15 += nonce[3]; out[0] = cpu_to_le32(x0); out[1] = cpu_to_le32(x1); out[2] = cpu_to_le32(x2); out[3] = cpu_to_le32(x3); out[4] = cpu_to_le32(x4); out[5] = cpu_to_le32(x5); out[6] = cpu_to_le32(x6); out[7] = cpu_to_le32(x7); out[8] = cpu_to_le32(x8); out[9] = cpu_to_le32(x9); out[10] = cpu_to_le32(x10); out[11] = cpu_to_le32(x11); out[12] = cpu_to_le32(x12); out[13] = cpu_to_le32(x13); out[14] = cpu_to_le32(x14); out[15] = cpu_to_le32(x15); } int foundation_rngV1_generate(uint8_t newkey[CHACHA_KEY_SIZE], uint8_t *dst, uint8_t key[CHACHA_KEY_SIZE], FsCountOf bytes) { const int rounds = 20; uint8_t nonce[CHACHA_NONCE_SIZE] = { 0 }; uint8_t buf[CHACHA_OUTPUT_SIZE]; /* for partial buffer */ if (!bytes) return 0; for (; bytes >= CHACHA_OUTPUT_SIZE; bytes -= CHACHA_OUTPUT_SIZE, dst += CHACHA_OUTPUT_SIZE) { chacha_core(rounds, dst, key, nonce); if (++nonce[0] == 0) nonce[1]++; } assert(bytes < CHACHA_OUTPUT_SIZE); chacha_core(rounds, buf, key, nonce); int remaining = CHACHA_OUTPUT_SIZE - bytes; if (remaining >= CHACHA_KEY_SIZE) { memcpy(dst, buf, bytes); memcpy(newkey, buf + bytes, CHACHA_KEY_SIZE); } else { memcpy(dst, buf, bytes); if (++nonce[0] == 0) nonce[1]++; chacha_core(rounds, buf, key, nonce); memcpy(newkey, buf, CHACHA_KEY_SIZE); } memset(buf, 0, CHACHA_OUTPUT_SIZE); return 0; } int foundation_rngV1_generate_word32(uint8_t newkey[CHACHA_KEY_SIZE], uint32_t *dst_w, uint8_t key[CHACHA_KEY_SIZE]) { return foundation_rngV1_generate(newkey, (uint8_t*)dst_w, key, sizeof(uint32_t)); } int foundation_rngV1_generate_word64(uint8_t newkey[CHACHA_KEY_SIZE], uint64_t *dst_w, uint8_t key[CHACHA_KEY_SIZE]) { return foundation_rngV1_generate(newkey, (uint8_t*)dst_w, key, sizeof(uint64_t)); } int foundation_rngV1_generate_f32(uint8_t newkey[CHACHA_KEY_SIZE], float *dst_w, uint8_t key[CHACHA_KEY_SIZE]) { uint32_t const UPPER_MASK = 0x3F800000UL; uint32_t const LOWER_MASK = 0x007FFFFFUL; uint32_t tmp32; int r = foundation_rngV1_generate_word32(newkey, &tmp32, key); tmp32 = UPPER_MASK | (tmp32 & LOWER_MASK); *dst_w = (float)tmp32 - 1.0; return r; } int foundation_rngV1_generate_f64(uint8_t newkey[CHACHA_KEY_SIZE], double *dst_w, uint8_t key[CHACHA_KEY_SIZE]) { uint64_t const UPPER_MASK = 0x3FF0000000000000ULL; uint64_t const LOWER_MASK = 0x000FFFFFFFFFFFFFULL; uint64_t tmp64; int r = foundation_rngV1_generate_word64(newkey, &tmp64, key); tmp64 = UPPER_MASK | (tmp64 & LOWER_MASK); *dst_w = (double)tmp64 - 1.0; return r; } foundation-0.0.23/cbits/foundation_network.c0000644000000000000000000000042013415353646017325 0ustar0000000000000000#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 } foundation-0.0.23/cbits/foundation_time.c0000644000000000000000000000610013415353646016573 0ustar0000000000000000#include "foundation_system.h" #ifdef FOUNDATION_SYSTEM_API_NO_CLOCK typedef enum { FOUNDATION_CLOCK_REALTIME, FOUNDATION_CLOCK_MONOTONIC, FOUNDATION_CLOCK_PROCESS_CPUTIME_ID, FOUNDATION_CLOCK_THREAD_CPUTIME_ID } foundation_clockid_t; #ifdef FOUNDATION_SYSTEM_MACOS #include #include #include #include /* OSX MONOTONIC COMPAT: * http://web.archive.org/web/20100517095152/http://www.wand.net.nz/~smr26/wordpress/2009/01/19/monotonic-time-in-mac-os-x/comment-page-1/ */ static mach_timebase_info_data_t timebase = {0,0}; int foundation_time_clock_getres(unsigned int clockid, struct timespec *timespec) { switch (clockid) { /* clockid = 1 (FOUNDATION_CLOCK_MONOTONIC), or any other value */ case FOUNDATION_CLOCK_MONOTONIC: if (timebase.denom == 0) mach_timebase_info(&timebase); timespec->tv_sec = 0; timespec->tv_nsec = timebase.numer / timebase.denom; break; /* clockid = 0 (FOUNDATION_CLOCK_REALTIME), or any other value */ case FOUNDATION_CLOCK_REALTIME: return -1; } return -1; } int foundation_time_clock_gettime(unsigned int clockid, struct timespec *timespec) { clock_serv_t cclock; mach_timespec_t mts; switch (clockid) { #if 0 case CLOCK_MONOTONIC: { uint64_t t, nanos; if (timebase.denom == 0) mach_timebase_info(timebase); t = mach_absolute_time(); nanos = t * (timebase.numer / timebase.denom); timespec->tv_sec = t / 1e9; timespec->tv_nsec = t % 1e9; break; case CLOCK_PROCESS_CPUTIME_ID: break; #endif case FOUNDATION_CLOCK_MONOTONIC: host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &cclock); clock_get_time(cclock, &mts); mach_port_deallocate(mach_task_self(), cclock); timespec->tv_sec = mts.tv_sec; timespec->tv_nsec = mts.tv_nsec; break; case FOUNDATION_CLOCK_REALTIME: host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); clock_get_time(cclock, &mts); mach_port_deallocate(mach_task_self(), cclock); timespec->tv_sec = mts.tv_sec; timespec->tv_nsec = mts.tv_nsec; break; default: return -1; } return 0; } #elif defined(FOUNDATION_SYSTEM_WINDOWS) #include // from: // https://stackoverflow.com/questions/5404277/porting-clock-gettime-to-windows struct timespec { long tv_sec; long tv_nsec; }; //header part #define BILLION (1E9) int foundation_time_clock_getres(unsigned int clockid, struct timespec *timespec) { } int foundation_time_clock_gettime(unsigned int clockid, struct timespec *ct) { LARGE_INTEGER count; static LARGE_INTEGER counts_per_sec = { .QuadPart = -1 }; switch (clockid) { case FOUNDATION_CLOCK_MONOTONIC: if (counts_per_sec.QuadPart == -1) { if (0 == QueryPerformanceFrequency(&counts_per_sec)) { counts_per_sec.QuadPart = 0; } } if ((NULL == ct) || (counts_per_sec.QuadPart <= 0) || (0 == QueryPerformanceCounter(&count))) { return -1; } ct->tv_sec = count.QuadPart / counts_per_sec.QuadPart; ct->tv_nsec = ((count.QuadPart % counts_per_sec.QuadPart) * BILLION) / counts_per_sec.QuadPart; break; default: return -1; } return 0; } #endif #endif foundation-0.0.23/cbits/foundation_utf8.c0000644000000000000000000000436413415353646016535 0ustar0000000000000000#include #include #include "foundation_prim.h" #if 0 static const uint64_t utf8_mask_80 = 0x8080808080808080ULL; static const uint64_t utf8_mask_40 = 0x4040404040404040ULL; typedef unsigned long pu; #define POPCOUNT(x) __builtin_popcountl(x) #define ALIGNED8(p) ((((uintptr_t) (p)) & (sizeof(pu)-1)) == 0) FsCountOf foundation_utf8_length(uint8_t *p8, const FsOffset start_offset, const FsOffset end_offset) { const uint8_t *end = p8 + end_offset; FsCountOf n = 0; p8 += start_offset; while (!ALIGNED8(p8) && p8 < end) { if ((*p8++ & 0xc0) != 0x80) { n++; } } /* process 8 bytes */ for (; (p8 + sizeof(pu)) <= end; p8 += sizeof(pu)) { pu h = *((pu *) p8); pu h80 = h & utf8_mask_80; /* only ASCII */ if (h80 == 0) { n += sizeof(pu); continue; } int nb_ascii = (h80 == utf8_mask_80) ? 0 : (8 - __builtin_popcountl(h80)); int nb_high = __builtin_popcountl( h & (h80 >> 1)); n += nb_ascii + nb_high; } while (p8 < end) { if ((*p8++ & 0xc0) != 0x80) { n++; } } return n; } #define IS_CONT(x) ((x & 0xc0) == 0x80) int foundation_utf8_validate(const uint8_t *c, size_t offset, size_t end) { while (offset < end) { uint8_t h = c[offset]; if (!(h & 0x80)) { offset++; continue; } /* continuation */ if (h < 0xC0) { goto fail1; } /* 2 bytes */ else if (h < 0xE0) { if (offset + 1 >= end) { goto fail2; } else if (IS_CONT(c[offset+1])) { offset += 2; } else { goto fail1; } } /* 3 bytes */ else if (h < 0xF0) { if (offset + 2 >= end) { goto fail2; } else if (IS_CONT(c[offset+1]) && IS_CONT(c[offset+2])) { offset += 3; } else { goto fail1; } } /* 4 bytes */ else if (h < 0xFE) { if (offset + 3 >= end) { goto fail2; } else if (IS_CONT(c[offset+1]) && IS_CONT(c[offset+2]) && IS_CONT(c[offset+3])) { offset += 4; } else { goto fail1; } } /* invalid > 4 bytes */ else { goto fail1; } } return 0; fail1: return 1; fail2: return 2; } #endif foundation-0.0.23/tests/DocTest.hs0000644000000000000000000000116313415353646015206 0ustar0000000000000000module Main where import Test.DocTest import Prelude main :: IO () main = doctest (extensions ++ flags ++ files) extensions :: [String] extensions = [ "-XBangPatterns" , "-XDeriveDataTypeable" , "-XNoImplicitPrelude" , "-XRebindableSyntax" , "-XOverloadedStrings" , "-XTypeFamilies" ] flags :: [String] flags = ["-fobject-code"] -- Would be nice to just use "src" here, but both Basement.String and -- Foundation.String.UTF8LL share the same module name, and doctest breaks. files :: [String] files = [ "Foundation/Collection/Buildable.hs" , "Foundation/VFS/FilePath.hs" , "Foundation/VFS/Path.hs" ] foundation-0.0.23/tests/Scripts/Link.hs0000644000000000000000000000077013415353646016170 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | This module is to test issue -- https://github.com/haskell-foundation/foundation/issues/326 -- -- this test has been originaly proposed by https://github.com/RyanGlScott -- in comment of the issue 326: -- https://github.com/haskell-foundation/foundation/issues/326#issuecomment-309219955 module Main (main) where import Foundation as F import Language.Haskell.TH main :: IO () main = $(do runIO $ F.putStrLn (F.fromString "Hello") [| return () |]) foundation-0.0.23/tests/Checks.hs0000644000000000000000000002410113415353646015036 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP #-} module Main where import Foundation import Foundation.Array import Foundation.Foreign import Foundation.List.DList import Foundation.Primitive import Foundation.Check import Foundation.Check.Main (defaultMain) import Foundation.String import Foundation.String.Read import qualified Prelude import Data.Ratio import Test.Foundation.Random import Test.Foundation.Misc import Test.Foundation.Storable import Test.Foundation.Number import Test.Foundation.Conduit import Test.Foundation.String import Test.Foundation.Network.IPv4 import Test.Foundation.Network.IPv6 import Test.Foundation.String.Base64 import Test.Checks.Property.Collection import Test.Foundation.Format import qualified Test.Foundation.Bits as Bits import qualified Test.Basement as Basement #if MIN_VERSION_base(4,9,0) import Test.Foundation.Primitive.BlockN #endif applyFstToSnd :: (String, String -> b) -> b applyFstToSnd (a, fab) = fab a matrixToGroup name l = Group name $ Prelude.concat $ fmap (fmap applyFstToSnd . snd) l functorProxy :: Proxy f -> Proxy ty -> Proxy (f ty) functorProxy _ _ = Proxy primTypesMatrixArbitrary :: (forall ty . (PrimType ty, Typeable ty, Show ty, Ord ty) => Proxy ty -> Gen ty -> a) -> [(String, [(String, a)])] primTypesMatrixArbitrary f = [ ("Words", [ ("W8", f (Proxy :: Proxy Word8) arbitrary) , ("W16", f (Proxy :: Proxy Word16) arbitrary) , ("W32", f (Proxy :: Proxy Word32) arbitrary) , ("W64", f (Proxy :: Proxy Word64) arbitrary) , ("W128", f (Proxy :: Proxy Word128) arbitrary) , ("W256", f (Proxy :: Proxy Word256) arbitrary) , ("Word", f (Proxy :: Proxy Word) arbitrary) ]) , ("Ints", [ ("I8", f (Proxy :: Proxy Int8) arbitrary) , ("I16", f (Proxy :: Proxy Int16) arbitrary) , ("I32", f (Proxy :: Proxy Int32) arbitrary) , ("I64", f (Proxy :: Proxy Int64) arbitrary) , ("Int", f (Proxy :: Proxy Int) arbitrary) ]) , ("Floating", [ ("FP32", f (Proxy :: Proxy Float) arbitrary) , ("FP64", f (Proxy :: Proxy Double) arbitrary) ]) , ("C-Types", [ ("CChar", f (Proxy :: Proxy CChar) (CChar <$> arbitrary)) , ("CUChar", f (Proxy :: Proxy CUChar) (CUChar <$> arbitrary)) ]) , ("Endian", [ ("BE-W16", f (Proxy :: Proxy (BE Word16)) (toBE <$> arbitrary)) , ("BE-W32", f (Proxy :: Proxy (BE Word32)) (toBE <$> arbitrary)) , ("BE-W64", f (Proxy :: Proxy (BE Word64)) (toBE <$> arbitrary)) , ("LE-W16", f (Proxy :: Proxy (LE Word16)) (toLE <$> arbitrary)) , ("LE-W32", f (Proxy :: Proxy (LE Word32)) (toLE <$> arbitrary)) , ("LE-W64", f (Proxy :: Proxy (LE Word64)) (toLE <$> arbitrary)) ]) ] testAdditive :: forall a . (Show a, Eq a, Typeable 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 ] readFloatingExact' :: String -> Maybe (Bool, Natural, Word, Maybe Int) readFloatingExact' str = readFloatingExact str (\s x y z -> Just (s,x,y,z)) doubleEqualApprox :: Double -> Double -> PropertyCheck doubleEqualApprox d1 d2 = propertyCompare name (<) (abs d) lim where d = d2 - d1 name = show d1 <> " - " <> show d2 <> " (differential=" <> show (abs d) <> " )" <> " < " <> show lim lim = min d1 d2 * (10^^(-15 :: Int)) main = defaultMain $ Group "foundation" [ Group "Numerical" [ Group "Int" [ testAdditive (Proxy :: Proxy Int) ] , Group "Word64" [ testAdditive (Proxy :: Proxy Word64) ] , Group "Number" testNumberRefs ] , Basement.tests , Bits.tests , Group "String" [ Group "reading" [ Group "integer" [ Property "empty" $ readInteger "" === Nothing , Property "just-sign" $ readInteger "-" === Nothing , Property "extra-content" $ readInteger "-123a" === Nothing , Property "any" $ \i -> readInteger (show i) === Just i ] , Group "floating-exact" [ Property "empty" $ readFloatingExact' "" === Nothing , Property "just-sign" $ readFloatingExact' "-" === Nothing , Property "extra-content" $ readFloatingExact' "-123a" === Nothing , Property "no-dot-after" $ readFloatingExact' "-123." === Nothing , Property "case0" $ readFloatingExact' "124890" === Just (False, 124890, 0, Nothing) , Property "case1" $ readFloatingExact' "-123.1" === Just (True, 1231, 1, Nothing) , Property "case2" $ readFloatingExact' "10001.001" === Just (False, 10001001, 3, Nothing) {- , Property "any" $ \s i (v :: Word8) n -> let (integral,floating) = i `divMod` (10^v) let vw = integralUpsize v :: Word sfloat = show n digits = integralCast (length sfloat) + vw in readFloatingExact' ((if s then "-" else "") <> show i <> "." <> replicate vw '0' <> sfloat) === Just (s, i, Just (digits, n), Nothing) -} ] , Group "Double" [ Property "case1" $ readDouble "96152.5" === Just 96152.5 , Property "case2" $ maybe (propertyFail "Nothing") (doubleEqualApprox 1.2300000000000002e102) $ readDouble "1.2300000000000002e102" , Property "case3" $ maybe (propertyFail "Nothing") (doubleEqualApprox 0.00001204) $ readDouble "0.00001204" , Property "case4" $ maybe (propertyFail "Nothing") (doubleEqualApprox 2.5e12) $ readDouble "2.5e12" , Property "case5" $ maybe (propertyFail "Nothing") (doubleEqualApprox 6.0e-4) $ readDouble "6.0e-4" , Property "case6" $ maybe (propertyFail "Nothing") ((===) (-31.548)) $ readDouble "-31.548" , Property "case7" $ readDouble "1e100000000" === Just (1/0) , Property "Prelude.read" $ \(d :: Double) -> case readDouble (show d) of Nothing -> propertyFail "Nothing" Just d' -> d' `doubleEqualApprox` (Prelude.read $ toList $ show d) ] , Group "rational" [ Property "case1" $ readRational "124.098" === Just (124098 % 1000) ] ] , Group "conversion" [ Property "lower" $ lower "This is MY test" === "this is my test" , Property "upper" $ upper "This is MY test" === "THIS IS MY TEST" ] ] , collectionProperties "DList a" (Proxy :: Proxy (DList Word8)) arbitrary , collectionProperties "Bitmap" (Proxy :: Proxy Bitmap) arbitrary , Group "Array" [ matrixToGroup "Block" $ primTypesMatrixArbitrary $ \prx arb s -> collectionProperties ("Block " <> s) (functorProxy (Proxy :: Proxy Block) prx) arb , matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy UArray) prx) arb , Group "Boxed" [ collectionProperties "Array(W8)" (Proxy :: Proxy (Array Word8)) arbitrary , collectionProperties "Array(W16)" (Proxy :: Proxy (Array Word16)) arbitrary , collectionProperties "Array(W32)" (Proxy :: Proxy (Array Word32)) arbitrary , collectionProperties "Array(W64)" (Proxy :: Proxy (Array Word64)) arbitrary , collectionProperties "Array(I8)" (Proxy :: Proxy (Array Int8)) arbitrary , collectionProperties "Array(I16)" (Proxy :: Proxy (Array Int16)) arbitrary , collectionProperties "Array(I32)" (Proxy :: Proxy (Array Int32)) arbitrary , collectionProperties "Array(I64)" (Proxy :: Proxy (Array Int64)) arbitrary , collectionProperties "Array(F32)" (Proxy :: Proxy (Array Float)) arbitrary , collectionProperties "Array(F64)" (Proxy :: Proxy (Array Double)) arbitrary , collectionProperties "Array(Int)" (Proxy :: Proxy (Array Int)) arbitrary , collectionProperties "Array(Int,Int)" (Proxy :: Proxy (Array (Int,Int))) arbitrary , collectionProperties "Array(Integer)" (Proxy :: Proxy (Array Integer)) arbitrary , collectionProperties "Array(CChar)" (Proxy :: Proxy (Array CChar)) (CChar <$> arbitrary) , collectionProperties "Array(CUChar)" (Proxy :: Proxy (Array CUChar)) (CUChar <$> arbitrary) , collectionProperties "Array(BE W16)" (Proxy :: Proxy (Array (BE Word16))) (toBE <$> arbitrary) , collectionProperties "Array(BE W32)" (Proxy :: Proxy (Array (BE Word32))) (toBE <$> arbitrary) , collectionProperties "Array(BE W64)" (Proxy :: Proxy (Array (BE Word64))) (toBE <$> arbitrary) , collectionProperties "Array(LE W16)" (Proxy :: Proxy (Array (LE Word16))) (toLE <$> arbitrary) , collectionProperties "Array(LE W32)" (Proxy :: Proxy (Array (LE Word32))) (toLE <$> arbitrary) , collectionProperties "Array(LE W64)" (Proxy :: Proxy (Array (LE Word64))) (toLE <$> arbitrary) ] ] , Group "ChunkedUArray" [ matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy ChunkedUArray) prx) arb ] , testStringRefs , testForeignStorableRefs , testNetworkIPv4 , testNetworkIPv6 , testBase64Refs , testHexadecimal , testUUID , testRandom , testConduit #if MIN_VERSION_base(4,9,0) , testBlockN #endif , testFormat ] foundation-0.0.23/tests/Test/Checks/Property/Collection.hs0000644000000000000000000004245613415353646021711 0ustar0000000000000000-- | -- Module : Test.Checks.Property.Collection -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : stable -- Portability : portable -- -- This module contains all the different property tests for the Foundation's -- collection classes. -- -- You can either run all the collection property tests with the -- @collectionProperties@ function or run them individually. -- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Test.Checks.Property.Collection ( collectionProperties , -- * properties per class testEqualityProperties , testOrderingProperties , testIsListPropertyies , testMonoidProperties , testCollectionProperties , testSequentialProperties , fromListP , toListP ) where import Foundation import Foundation.Collection import Foundation.Check import Control.Monad (replicateM) import qualified Prelude (replicate) -- | convenient function to replicate thegiven Generator of `e` a randomly -- choosen amount of time. generateListOfElement :: Gen e -> Gen [e] generateListOfElement = generateListOfElementMaxN 100 -- | convenient function to generate up to a certain amount of time the given -- generator. generateListOfElementMaxN :: Word -> Gen e -> Gen [e] generateListOfElementMaxN n e = between (0,n) >>= flip replicateM e . fromIntegral generateNonEmptyListOfElement :: Word -> Gen e -> Gen (NonEmpty [e]) generateNonEmptyListOfElement n e = nonEmpty_ <$> (between (1,n) >>= flip replicateM e . fromIntegral) -- | internal helper to convert a list of element into a collection -- fromListP :: (IsList c, Item c ~ Element c) => Proxy c -> [Element c] -> c fromListP p = \x -> asProxyTypeOf (fromList x) p fromListNonEmptyP :: Collection a => Proxy a -> NonEmpty [Element a] -> NonEmpty a fromListNonEmptyP proxy = nonEmpty_ . fromListP proxy . getNonEmpty -- | internal helper to convert a given Collection into a list of its element -- toListP :: (IsList c, Item c ~ Element c) => Proxy c -> c -> [Element c] toListP p x = toList (asProxyTypeOf x p) -- | test all the diffent classes of a Foundation's collection class -- -- * testEqualityProperties -- * testOrderingProperties -- * testIsListPropertyies -- * testMonoidProperties -- * testCollectionProperties -- * testSequentialProperties -- collectionProperties :: forall collection . ( Sequential collection , Typeable collection, Typeable (Element collection) , Eq collection, Eq (Element collection) , Show collection, Show (Element collection) , Ord collection, Ord (Element collection) ) => String -> Proxy collection -> Gen (Element collection) -> Test collectionProperties name proxy genElement = Group name [ testEqualityProperties proxy genElement , testOrderingProperties proxy genElement , testIsListPropertyies proxy genElement , testMonoidProperties proxy genElement , testCollectionProperties proxy genElement , testSequentialProperties proxy genElement ] -- | test property equality for the given Collection -- -- This does to enforce testEqualityProperties :: forall collection . ( IsList collection , Element collection ~ Item collection , Typeable collection , Eq collection, Eq (Element collection) , Show collection, Show (Element collection) , Ord collection, Ord (Element collection) ) => Proxy collection -> Gen (Element collection) -> Test testEqualityProperties proxy genElement = Group "equality" [ Property "x == x" $ withElements $ \l -> let col = fromListP proxy l in col === col , Property "x == y" $ with2Elements $ \(l1, l2) -> (fromListP proxy l1 == fromListP proxy l2) === (l1 == l2) ] where withElements f = forAll (generateListOfElement genElement) f with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f testOrderingProperties :: forall collection . ( IsList collection , Element collection ~ Item collection , Typeable collection , Eq collection, Eq (Element collection) , Show collection, Show (Element collection) , Ord collection, Ord (Element collection) ) => Proxy collection -> Gen (Element collection) -> Test testOrderingProperties proxy genElement = Group "ordering" [ Property "x `compare` y" $ with2Elements $ \(l1, l2) -> (fromListP proxy l1 `compare` fromListP proxy l2) === (l1 `compare` l2) ] where with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f testIsListPropertyies :: forall collection . ( IsList collection, Eq collection, Show collection , Typeable collection, Typeable (Element collection) , Element collection ~ Item collection , Eq (Item collection), Show (Item collection) ) => Proxy collection -> Gen (Element collection) -> Test testIsListPropertyies proxy genElement = Group "IsList" [ Property "fromList . toList == id" $ withElements $ \l -> (toList $ fromListP proxy l) === l ] where withElements f = forAll (generateListOfElement genElement) f testMonoidProperties :: forall collection . ( Monoid collection, IsList collection, Eq collection, Show collection , Typeable collection, Typeable (Element collection) , Element collection ~ Item collection , Eq (Item collection), Show (Item collection) ) => Proxy collection -> Gen (Element collection) -> Test testMonoidProperties proxy genElement = Group "Monoid" [ Property "mempty <> x == x" $ withElements $ \l -> let col = fromListP proxy l in (col <> mempty) === col , Property "x <> mempty == x" $ withElements $ \l -> let col = fromListP proxy l in (mempty <> col) === col , Property "x1 <> x2 == x1|x2" $ with2Elements $ \(l1,l2) -> (fromListP proxy l1 <> fromListP proxy l2) === fromListP proxy (l1 <> l2) , Property "mconcat [map fromList [e]] = fromList (concat [e])" $ withNElements $ \l -> mconcat (fmap (fromListP proxy) l) === fromListP proxy (mconcat l) ] where withElements f = forAll (generateListOfElement genElement) f with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f withNElements f = forAll (generateListOfElementMaxN 5 (generateListOfElement genElement)) f -- | test the Foundation's @Collection@ class. -- testCollectionProperties :: forall collection . ( Collection collection , Typeable collection, Typeable (Element collection) , Show (Element collection), Eq (Element collection) , Ord (Element collection) , Ord collection ) => Proxy collection -- ^ a proxy for the collection to test -> Gen (Element collection) -- ^ a generator to generate elements for the collection -> Test testCollectionProperties proxy genElement = Group "Collection" [ Property "null mempty" $ (null $ fromListP proxy []) === True , Property "null . getNonEmpty" $ withNonEmptyElements $ \els -> (null $ fromListP proxy $ getNonEmpty els) === False , Property "length" $ withElements $ \l -> (length $ fromListP proxy l) === length l , Property "elem" $ withListAndElement $ \(l,e) -> elem e (fromListP proxy l) === elem e l , Property "notElem" $ withListAndElement $ \(l,e) -> notElem e (fromListP proxy l) === notElem e l , Property "minimum" $ withNonEmptyElements $ \els -> minimum (fromListNonEmptyP proxy els) === minimum els , Property "maximum" $ withNonEmptyElements $ \els -> maximum (fromListNonEmptyP proxy els) === maximum els , Property "all" $ withListAndElement $ \(l, e) -> (all (/= e) (fromListP proxy l) === all (/= e) l) `propertyAnd` (all (== e) (fromListP proxy l) === all (== e) l) , Property "any" $ withListAndElement $ \(l, e) -> (any (/= e) (fromListP proxy l) === any (/= e) l) `propertyAnd` (any (== e) (fromListP proxy l) === any (== e) l) ] where withElements f = forAll (generateListOfElement genElement) f withListAndElement = forAll ((,) <$> generateListOfElement genElement <*> genElement) withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f testSequentialProperties :: forall collection . ( Sequential collection , Typeable collection, Typeable (Element collection) , Eq collection, Eq (Element collection) , Ord collection, Ord (Element collection) , Show collection, Show (Element collection) ) => Proxy collection -> Gen (Element collection) -> Test testSequentialProperties proxy genElement = Group "Sequential" [ Property "take" $ withElements2 $ \(l, n) -> toList (take n $ fromListP proxy l) === (take n) l , Property "drop" $ withElements2 $ \(l, n) -> toList (drop n $ fromListP proxy l) === (drop n) l , Property "splitAt" $ withElements2 $ \(l, n) -> toList2 (splitAt n $ fromListP proxy l) === (splitAt n) l , Property "revTake" $ withElements2 $ \(l, n) -> toList (revTake n $ fromListP proxy l) === (revTake n) l , Property "revDrop" $ withElements2 $ \(l, n) -> toList (revDrop n $ fromListP proxy l) === (revDrop n) l , Property "revSplitAt" $ withElements2 $ \(l, n) -> toList2 (revSplitAt n $ fromListP proxy l) === (revSplitAt n) l , Property "break" $ withElements2E $ \(l, c) -> toList2 (break (== c) $ fromListP proxy l) === (break (== c)) l , Property "breakEnd" $ withElements2E $ \(l, c) -> toList2 (breakEnd (== c) $ fromListP proxy l) === (breakEnd (== c)) l , Property "breakElem" $ withElements2E $ \(l, c) -> toList2 (breakElem c $ fromListP proxy l) === (breakElem c) l , Property "span" $ withElements2E $ \(l, c) -> toList2 (span (== c) $ fromListP proxy l) === (span (== c)) l , Property "spanEnd" $ withElements2E $ \(l, c) -> toList2 (spanEnd (== c) $ fromListP proxy l) === (spanEnd (== c)) l , Property "filter" $ withElements2E $ \(l, c) -> toList (filter (== c) $ fromListP proxy l) === (filter (== c)) l , Property "partition" $ withElements2E $ \(l, c) -> toList2 (partition (== c) $ fromListP proxy l) === (partition (== c)) l , Property "snoc" $ withElements2E $ \(l, c) -> toList (snoc (fromListP proxy l) c) === (l <> [c]) , Property "cons" $ withElements2E $ \(l, c) -> toList (cons c (fromListP proxy l)) === (c : l) , Property "unsnoc" $ withElements $ \l -> fmap toListFirst (unsnoc (fromListP proxy l)) === unsnoc l , Property "uncons" $ withElements $ \l -> fmap toListSecond (uncons (fromListP proxy l)) === uncons l , Property "head" $ withNonEmptyElements $ \els -> head (fromListNonEmptyP proxy els) === head els , Property "last" $ withNonEmptyElements $ \els -> last (fromListNonEmptyP proxy els) === last els , Property "tail" $ withNonEmptyElements $ \els -> toList (tail $ fromListNonEmptyP proxy els) === tail els , Property "init" $ withNonEmptyElements $ \els -> toList (init $ fromListNonEmptyP proxy els) === init els , Property "splitOn" $ withElements2E $ \(l, ch) -> fmap toList (splitOn (== ch) (fromListP proxy l)) === splitOn (== ch) l , testSplitOn proxy (const True) mempty , Property "intercalate c (splitOn (c ==) col) == col" $ withElements2E $ \(c, ch) -> intercalate [ch] (splitOn (== ch) c) === c , Property "intercalate c (splitOn (c ==) (col ++ [c]) == (col ++ [c])" $ withElements2E $ \(c, ch) -> intercalate [ch] (splitOn (== ch) $ snoc c ch) === (snoc c ch) , Property "intercalate c (splitOn (c ==) (col ++ [c,c]) == (col ++ [c,c])" $ withElements2E $ \(c, ch) -> intercalate [ch] (splitOn (== ch) $ snoc (snoc c ch) ch) === (snoc (snoc c ch) ch) , Property "intersperse" $ withElements2E $ \(l, c) -> toList (intersperse c (fromListP proxy l)) === intersperse c l , Property "intercalate" $ withElements2E $ \(l, c) -> let ls = Prelude.replicate 5 l cs = Prelude.replicate 5 c in toList (intercalate (fromListP proxy cs) (fromListP proxy <$> ls)) === intercalate cs ls , Property "sortBy" $ withElements $ \l -> (sortBy compare $ fromListP proxy l) === fromListP proxy (sortBy compare l) , Property "reverse" $ withElements $ \l -> (reverse $ fromListP proxy l) === fromListP proxy (reverse l) -- stress slicing , Property "take . take" $ withElements3 $ \(l, n1, n2) -> toList (take n2 $ take n1 $ fromListP proxy l) === (take n2 $ take n1 l) , Property "drop . take" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ take n1 $ fromListP proxy l) === (drop n2 $ take n1 l) , Property "drop . drop" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ drop n1 $ fromListP proxy l) === (drop n2 $ drop n1 l) , Property "drop . take" $ withElements3 $ \(l, n1, n2) -> toList (drop n2 $ take n1 $ fromListP proxy l) === (drop n2 $ take n1 l) , Property "second take . splitAt" $ withElements3 $ \(l, n1, n2) -> (toList2 $ (second (take n1) . splitAt n2) $ fromListP proxy l) === (second (take n1) . splitAt n2) l , Property "splitAt == (take, drop)" $ withCollection2 $ \(col, n) -> splitAt n col === (take n col, drop n col) , Property "revSplitAt == (revTake, revDrop)" $ withCollection2 $ \(col, n) -> revSplitAt n col === (revTake n col, revDrop n col) , Group "isSuffixOf" [ Property "collection + sub" $ withElements2 $ \(l1, n) -> let c1 = fromListP proxy l1 in isSuffixOf (revTake n c1) c1 === isSuffixOf (revTake n l1) l1 , Property "2 collections" $ with2Elements $ \(l1, l2) -> isSuffixOf (fromListP proxy l1) (fromListP proxy l2) === isSuffixOf l1 l2 , Property "collection + empty" $ withElements $ \l1 -> isSuffixOf (fromListP proxy []) (fromListP proxy l1) === isSuffixOf [] l1 ] , Group "isPrefixOf" [ Property "collection + sub" $ withElements2 $ \(l1, n) -> let c1 = fromListP proxy l1 in isPrefixOf (take n c1) c1 === isPrefixOf (take n l1) l1 , Property "2 collections" $ with2Elements $ \(l1, l2) -> isPrefixOf (fromListP proxy l1) (fromListP proxy l2) === isPrefixOf l1 l2 , Property "collection + empty" $ withElements $ \l1 -> isPrefixOf (fromListP proxy []) (fromListP proxy l1) === isPrefixOf [] l1 ] , Group "isInfixOf" [ Property "b isInfixOf 'a b c'" $ with3Elements $ \(a, b, c) -> isInfixOf (toCol b) (toCol a <> toCol b <> toCol c) , Property "the reverse is typically not an infix" $ withElements $ \a' -> let a = toCol a'; rev = reverse a in isInfixOf rev a === (a == rev) ] ] {- , testProperty "imap" $ \(CharMap (LUString u) i) -> (imap (addChar i) (fromList u) :: String) `assertEq` fromList (Prelude.map (addChar i) u) ] -} where toCol = fromListP proxy toList2 (x,y) = (toList x, toList y) toListFirst (x,y) = (toList x, y) toListSecond (x,y) = (x, toList y) withElements f = forAll (generateListOfElement genElement) f with2Elements f = forAll ((,) <$> generateListOfElement genElement <*> generateListOfElement genElement) f with3Elements f = forAll ((,,) <$> generateListOfElement genElement <*> generateListOfElement genElement <*> generateListOfElement genElement) f withElements2 f = forAll ((,) <$> generateListOfElement genElement <*> arbitrary) f withElements3 f = forAll ((,,) <$> generateListOfElement genElement <*> arbitrary <*> arbitrary) f withElements2E f = forAll ((,) <$> generateListOfElement genElement <*> genElement) f withNonEmptyElements f = forAll (generateNonEmptyListOfElement 80 genElement) f withCollection2 f = forAll ((,) <$> (fromListP proxy <$> generateListOfElement genElement) <*> arbitrary) f testSplitOn :: ( Sequential a , Show a, Show (Element a) , Typeable a , Eq (Element a) , Eq a, Ord a, Ord (Item a), Show a ) => Proxy a -> (Element a -> Bool) -> a -> Test testSplitOn _ predicate col = Property "splitOn (const True) mempty == [mempty]" $ (splitOn predicate col) === [col] foundation-0.0.23/tests/Test/Foundation/Random.hs0000644000000000000000000000760413415353646020114 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module Test.Foundation.Random ( testRandom ) where import Foundation import Foundation.Check import Foundation.Primitive import Foundation.Array import Foundation.Collection import Foundation.System.Entropy import Foundation.Random import qualified Prelude import qualified Data.List import GHC.ST testRandom :: Test testRandom = Group "random" [ CheckPlan "entropy" entropyCheck , CheckPlan "rngv1" rngv1Check ] entropyCheck, rngv1Check :: Check () entropyCheck = pick "get-entropy" (getEntropy 1024) >>= testDataAppearRandom rngv1Check = pick "get-rng" getRng >>= testDataAppearRandom where getRng = do rng <- randomNew :: IO RNG pure $ mconcat $ fst $ withRandomGenerator rng $ mapM getRandomBytes [1,2,4,8,32,80,250,2139] -- property to check that the data appears random enough -- -- if this test fails it doesn't necessarily means it's not normal. testDataAppearRandom :: UArray Word8 -> Check () testDataAppearRandom dat = do validate "entropy" $ (\x -> x > 6.5 && x <= 8) (res_entropy v) validate "mean" $ (\x -> x >= 112 && x <= 144) (res_mean v) validate "compression" $ (\x -> x >= 0 && x <= 5.0) (res_compressionPercent v) where v = randomTest dat -------- generic random testing data RandomTestResult = RandomTestResult { res_totalChars :: Word64 -- ^ Total number of characters , res_entropy :: Double -- ^ Entropy per byte , res_chi_square :: Double -- ^ Chi Square , res_mean :: Double -- ^ Arithmetic Mean , res_compressionPercent :: Double -- ^ Theorical Compression percent , res_probs :: [Double] -- ^ Probability of every bucket } deriving (Show,Eq) -- | Mutable random test State newtype RandomTestState s = RandomTestState (MUArray Word64 (PrimState (ST s))) -- | Initialize new state to run tests randomTestInitialize :: ST s (RandomTestState s) randomTestInitialize = do m <- mutNew 256 forM_ [0..255] $ \i -> mutWrite m i 0 return $ RandomTestState m -- | Append random data to the test state randomTestAppend :: RandomTestState s -> UArray Word8 -> ST s () randomTestAppend (RandomTestState buckets) = mapM_ (addVec 1 . Offset . fromIntegral) . toList where addVec a i = mutRead buckets i >>= \d -> mutWrite buckets i $! d+a -- | Finalize random test state into some result randomTestFinalize :: RandomTestState s -> ST s RandomTestResult randomTestFinalize (RandomTestState buckets) = (calculate . toList) <$> freeze buckets randomTest :: UArray Word8 -> RandomTestResult randomTest a = runST $ do st <- randomTestInitialize randomTestAppend st a randomTestFinalize st calculate :: [Word64] -> RandomTestResult calculate buckets = RandomTestResult { res_totalChars = totalChars , res_entropy = entropy , res_chi_square = chisq , res_mean = fromIntegral datasum Prelude./ fromIntegral totalChars , res_compressionPercent = 100.0 * (8 - entropy) Prelude./ 8.0 , res_probs = probs } where totalChars = Prelude.sum buckets probs = fmap (\v -> fromIntegral v Prelude./ fromIntegral totalChars :: Double) buckets entropy = Data.List.foldl' accEnt 0.0 probs cexp = fromIntegral totalChars Prelude./ 256.0 :: Double (datasum, chisq) = foldl' accMeanChi (0, 0.0) $ Prelude.zip [0..255] buckets --chip' = abs (sqrt (2.0 * chisq) - sqrt (2.0 * 255.0 - 1.0)) accEnt ent pr | pr > 0.0 = ent + (pr * xlog (1 Prelude./ pr)) | otherwise = ent xlog v = Prelude.logBase 10 v * (Prelude.logBase 2 10) accMeanChi :: (Word64, Double) -> (Int, Word64) -> (Word64, Double) accMeanChi (dataSum, chiSq) (i, ccount) = let a = fromIntegral ccount - cexp in (dataSum + fromIntegral i * ccount, chiSq + (a * a Prelude./ cexp)) foundation-0.0.23/tests/Test/Foundation/Misc.hs0000644000000000000000000000245113415353646017562 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Test.Foundation.Misc ( testHexadecimal , testUUID ) where import Foundation import Foundation.Check import Foundation.Array.Internal (toHexadecimal) import Test.Checks.Property.Collection (fromListP) import qualified Foundation.UUID as UUID import Foundation.Parser instance Arbitrary UUID.UUID where arbitrary = UUID.UUID <$> arbitrary <*> arbitrary hex :: [Word8] -> [Word8] hex = loop where toHex :: Int -> Word8 toHex n | n < 10 = fromIntegral (n + fromEnum '0') | otherwise = fromIntegral (n - 10 + fromEnum 'a') loop [] = [] loop (x:xs) = toHex (fromIntegral q):toHex (fromIntegral r):loop xs where (q,r) = x `divMod` 16 testHexadecimal = Group "hexadecimal" [ Property "UArray(W8)" $ \l -> toList (toHexadecimal (fromListP (Proxy :: Proxy (UArray Word8)) l)) == hex l ] testUUID = Group "UUID" [ Property "show" $ show UUID.nil === "00000000-0000-0000-0000-000000000000" , Property "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" , Property "parser . show = id" $ \uuid -> (either (error . show) id $ parseOnly UUID.uuidParser (show uuid)) === uuid ] foundation-0.0.23/tests/Test/Foundation/Conduit.hs0000644000000000000000000000340513415353646020274 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module Test.Foundation.Conduit ( testConduit ) where import Foundation import Foundation.Check import Foundation.Conduit import Foundation.IO testConduit :: Test testConduit = Group "Conduit" [ CheckPlan "sourceHandle gives same data as readFile" testSourceFile , CheckPlan "sourceHandle/sinkHandle copies data" testCopyFile , CheckPlan "sourceFile/sinkFile copies data" testCopyFileRes ] where --testSourceFile :: Assertion testSourceFile = do let fp = "foundation.cabal" arrs <- pick "conduit-read" $ withFile fp ReadMode $ \h -> runConduit $ sourceHandle h .| sinkList arr <- pick "read-source" $ readFile fp validate "foundation.cabal contents" $ arr == (mconcat arrs) --testCopyFile :: Assertion testCopyFile = do let src = "foundation.cabal" dst = "temp-file" -- FIXME some temp file API? pick "conduit-duplicate" $ withFile src ReadMode $ \hin -> withFile dst WriteMode $ \hout -> runConduit $ sourceHandle hin .| sinkHandle hout orig <- pick "read-source" $ readFile src new <- pick "read-destination" $ readFile dst validate "copied foundation.cabal contents" $ orig == new --testCopyFileRes :: Assertion testCopyFileRes = do let src = "foundation.cabal" dst = "temp-file" -- FIXME some temp file API? pick "conduit-res" $ runConduitRes $ sourceFile src .| sinkFile dst orig <- pick "read-soure" $ readFile src new <- pick "read-destination" $ readFile dst validate "copied foundation.cabal contents" $ orig == new foundation-0.0.23/tests/Test/Foundation/Primitive/BlockN.hs0000644000000000000000000000367313415353646022016 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Test.Foundation.Primitive.BlockN ( testBlockN ) where import Data.Proxy (Proxy(..)) import Foundation hiding (singleton, replicate, cons, uncons, elem) import Basement.Nat import Basement.Types.OffsetSize import qualified Basement.Block as B import Basement.Sized.Block import Basement.From import Foundation.Check testBlockN = Group "BlockN" [ testWithDifferentN , Property "singleton" $ B.singleton (1 :: Int) === toBlock (singleton 1) ] testWithDifferentN = Group "Multiple n" $ do Foo n <- ns [testBlock n] testBlock :: forall n . (KnownNat n, NatWithinBound (CountOf Int) n) => Proxy n -> Test testBlock nProxy = Group ("n = " <> show size) [ Property "to/from block" $ block === (toBlock blockN) , Property "replicate" $ B.replicate size (7 :: Int) === toBlock (rep 7) , Property "length . cons" $ B.length (toBlock (cons 42 blockN)) === (size+1) , Property "elem" $ size == 0 || from size `elem` blockN ] where rep :: Int -> BlockN n Int rep = replicate size = natValCountOf nProxy block = createBlockSized size Just blockN = toBlockN block :: Maybe (BlockN n Int) createBlockSized :: CountOf Int -> B.Block Int createBlockSized n@(CountOf n') = B.create n (const n') data Foo = forall a . (KnownNat a, NatWithinBound (CountOf Int) a) => Foo (Proxy a) ns = [ Foo (Proxy :: Proxy 0) , Foo (Proxy :: Proxy 1) , Foo (Proxy :: Proxy 2) , Foo (Proxy :: Proxy 3) , Foo (Proxy :: Proxy 4) , Foo (Proxy :: Proxy 5) , Foo (Proxy :: Proxy 6) , Foo (Proxy :: Proxy 7) , Foo (Proxy :: Proxy 8) , Foo (Proxy :: Proxy 33) , Foo (Proxy :: Proxy 42) ] foundation-0.0.23/tests/Test/Foundation/Storable.hs0000644000000000000000000001367213415353646020451 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Test.Foundation.Storable ( testForeignStorableRefs , testPropertyStorable, testPropertyStorableFixed ) where import Foundation import Foundation.Class.Storable import Foundation.Primitive import Foundation.Check import qualified Foreign.Storable import qualified Foreign.Marshal.Alloc import qualified Foreign.Marshal.Array testForeignStorableRefs :: Test testForeignStorableRefs = Group "Storable" [ Group "Storable" [ testPropertyStorable "Word8" (Proxy :: Proxy Word8) , testPropertyStorable "Word16" (Proxy :: Proxy Word16) , testPropertyStorable "Word32" (Proxy :: Proxy Word32) , testPropertyStorable "Word64" (Proxy :: Proxy Word64) , testPropertyStorable "Int8" (Proxy :: Proxy Int8) , testPropertyStorable "Int16" (Proxy :: Proxy Int16) , testPropertyStorable "Int32" (Proxy :: Proxy Int32) , testPropertyStorable "Int64" (Proxy :: Proxy Int64) , testPropertyStorable "Char" (Proxy :: Proxy Char) , testPropertyStorable "Double" (Proxy :: Proxy Double) , testPropertyStorable "Float" (Proxy :: Proxy Float) ] , Group "StorableFixed" [ testPropertyStorableFixed "Word8" (Proxy :: Proxy Word8) , testPropertyStorableFixed "Word16" (Proxy :: Proxy Word16) , testPropertyStorableFixed "Word32" (Proxy :: Proxy Word32) , testPropertyStorableFixed "Word64" (Proxy :: Proxy Word64) , testPropertyStorableFixed "Int8" (Proxy :: Proxy Int8) , testPropertyStorableFixed "Int16" (Proxy :: Proxy Int16) , testPropertyStorableFixed "Int32" (Proxy :: Proxy Int32) , testPropertyStorableFixed "Int64" (Proxy :: Proxy Int64) , testPropertyStorableFixed "Char" (Proxy :: Proxy Char) , testPropertyStorableFixed "Double" (Proxy :: Proxy Double) , testPropertyStorableFixed "Float" (Proxy :: Proxy Float) ] , Group "Endianness" [ testPropertyBE "Word16" (Proxy :: Proxy Word16) , testPropertyBE "Word32" (Proxy :: Proxy Word32) , testPropertyBE "Word64" (Proxy :: Proxy Word64) ] ] testPropertyBE :: forall a . (ByteSwap a, StorableFixed a, Arbitrary a, Eq a, Show a, Typeable a) => String -> Proxy a -> Test testPropertyBE name p = Group name [ Property "fromBE . toBE == id" $ \(a :: a) -> fromBE (toBE a) === a , Property "fromLE . toLE == id" $ \(a :: a) -> fromLE (toLE a) === a ] testPropertyStorable :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => String -> Proxy a -> Test testPropertyStorable name p = Group name [ -- testPropertyStorablePeek p -- , testPropertyStorablePoke p ] testPropertyStorableFixed :: forall a . (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => String -> Proxy a -> Test testPropertyStorableFixed name p = Group name [ Property "size" $ \(a :: a) -> size p === (CountOf $ Foreign.Storable.sizeOf a) , Property "alignment" $ \(a :: a) -> alignment p === (CountOf $ Foreign.Storable.alignment a) --, testPropertyStorableFixedPeekOff p --, testPropertyStorableFixedPokeOff p ] testPropertyStorablePeek :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> a -> Test testPropertyStorablePeek _ v = CheckPlan "storable-peek" $ do v' <- pick "alloca" $ Foreign.Marshal.Alloc.alloca $ \ptr -> do Foreign.Storable.poke ptr v peek ptr validate "equal" $ v == v' testPropertyStorablePoke :: (Storable a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> a -> Test testPropertyStorablePoke _ v = CheckPlan "storable-poke" $ do v' <- pick "alloca" $ Foreign.Marshal.Alloc.alloca $ \ptr -> do poke ptr v Foreign.Storable.peek ptr validate "equal" $ v == v' {- assertEq a b | a == b = assert True | otherwise = do run $ putStrLn $ show a <> " /= " <> show b assert False -} data SomeWhereInArray a = SomeWhereInArray a Int Int deriving (Show, Eq) instance (StorableFixed a, Arbitrary a) => Arbitrary (SomeWhereInArray a) where arbitrary = do a <- arbitrary let p = Proxy :: Proxy a Just (CountOf minsz) = (size p + alignment p - size p) let sz = minsz + 1 let o = sz - minsz --sz <- choose (minsz, 512) --o <- choose (0, sz - minsz) return $ SomeWhereInArray a sz o {- testPropertyStorableFixedPeekOff :: (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> SomeWhereInArray a -> Test testPropertyStorableFixedPeekOff = CheckPlan "storable-fixed-peek-off" $ do (SomeWhereInArray v sz off) <- pick "x" arbitrary v' <- pick "alloca" $ Foreign.Marshal.Array.allocaArray sz $ \ptr -> do Foreign.Storable.pokeElemOff ptr off v peekOff ptr (Offset off) validate "equal" $ v == v' testPropertyStorableFixedPokeOff :: (StorableFixed a, Foreign.Storable.Storable a, Arbitrary a, Eq a, Show a) => Proxy a -> SomeWhereInArray a -> Test testPropertyStorableFixedPokeOff _ (SomeWhereInArray v sz off) = CheckPlan "storable-fixed-poke-off" $ do v' <- pick "alloca" $ Foreign.Marshal.Array.allocaArray sz $ \ptr -> do pokeOff ptr (Offset off) v Foreign.Storable.peekElemOff ptr off validate "equal" $ v == v' -} foundation-0.0.23/tests/Test/Foundation/Number.hs0000644000000000000000000001127013415353646020116 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Test.Foundation.Number ( testNumber , testNumberRefs ) where import Foundation import Foundation.Check import qualified Prelude testIntegral :: forall a . (Arbitrary a, Show a, IsIntegral a, Integral a, Typeable a) => Proxy a -> Test testIntegral _ = Group "Integral" [ Property "FromIntegral(Integer(a)) == a" $ \(a :: a) -> fromInteger (toInteger a) === a ] testEqOrd :: forall a . (Arbitrary a, Show a, Eq a, Ord a, IsIntegral a, Typeable a) => Proxy a -> Test testEqOrd _ = Group "Property" [ Property "Eq" $ \(a :: a) -> a === a -- , Property "Ne" $ \(a :: a) (b :: a) -> if a === w , Property "Show" $ \(a :: a) -> show a === show (toInteger a) , Property "Ord" $ \(a :: a) (b :: a) -> compare a b === (compare `on` toInteger) a b , Property "<" $ \(a :: a) (b :: a) -> case compare a b of LT -> propertyCompare "<" (<) a b GT -> propertyCompare "<" (<) b a EQ -> propertyCompare "not <" ((not .) . (<)) a b `propertyAnd` propertyCompare "not <" ((not .) . (<)) b a ] testAdditive :: forall a . (Show a, Eq a, Additive a, Arbitrary a, Typeable a) => Proxy a -> Test testAdditive _ = Group "Additive" [ Property "a + azero == a" $ \(a :: a) -> a + azero === a , Property "azero + a == a" $ \(a :: a) -> azero + a === a , Property "a + b == b + a" $ \(a :: a) (b :: a) -> a + b === b + a ] testMultiplicative :: forall a . (Show a, Eq a, IsIntegral a, Integral a, Multiplicative a, Arbitrary a, Typeable a) => Proxy a -> Test testMultiplicative _ = Group "Multiplicative" [ Property "a * 1 == a" $ \(a :: a) -> a * midentity === a , Property "1 * a == a" $ \(a :: a) -> midentity * a === a , Property "multiplication commutative" $ \(a :: a) (b :: a) -> a * b == b * a , Property "a * b == Integer(a) * Integer(b)" $ \(a :: a) (b :: a) -> a * b == fromInteger (toInteger a * toInteger b) ] testDividible :: forall a . (Show a, Eq a, IsIntegral a, IDivisible a, Arbitrary a, Typeable a) => Proxy a -> Test testDividible _ = Group "Divisible" [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) b -> if b == 0 then True === True else a === (a `div` b) * b + (a `mod` b) ] testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, IsIntegral a, Additive a, Subtractive a, Multiplicative a, Difference a ~ a, Arbitrary a, Typeable a) => Proxy a -> Test testOperatorPrecedence _ = Group "Precedence" [ Property "+ and - (1)" $ \(a :: a) (b :: a) (c :: a) -> (a + b - c) === ((a + b) - c) , Property "+ and - (2)" $ \(a :: a) (b :: a) (c :: a) -> (a - b + c) === ((a - b) + c) , Property "+ and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a + b * c) === (a + (b * c)) , Property "+ and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b + c) === ((a * b) + c) , Property "- and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a - b * c) === (a - (b * c)) , Property "- and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b - c) === ((a * b) - c) , Property "* and ^ (1)" $ \(a :: a) (b :: Natural) (c :: a) -> (a ^ b * c) === ((a ^ b) * c) , Property "* and ^ (2)" $ \(a :: a) (c :: Natural) (b :: a) -> (a * b ^ c) === (a * (b ^ c)) ] testNumber :: (Show a, Eq a, Prelude.Num a, IsIntegral a, Additive a, Multiplicative a, Subtractive a, Difference a ~ a, IDivisible a, Arbitrary a, Typeable a) => String -> Proxy a -> Test testNumber name proxy = Group name [ testIntegral proxy , testEqOrd proxy , testAdditive proxy , testMultiplicative proxy , testDividible proxy , testOperatorPrecedence proxy ] testNumberRefs :: [Test] testNumberRefs = [ testNumber "Int" (Proxy :: Proxy Int) , testNumber "Int8" (Proxy :: Proxy Int8) , testNumber "Int16" (Proxy :: Proxy Int16) , testNumber "Int32" (Proxy :: Proxy Int32) , testNumber "Int64" (Proxy :: Proxy Int64) , testNumber "Integer" (Proxy :: Proxy Integer) , testNumber "Word" (Proxy :: Proxy Word) , testNumber "Word8" (Proxy :: Proxy Word8) , testNumber "Word16" (Proxy :: Proxy Word16) , testNumber "Word32" (Proxy :: Proxy Word32) , testNumber "Word64" (Proxy :: Proxy Word64) , testNumber "Word128" (Proxy :: Proxy Word128) , testNumber "Word256" (Proxy :: Proxy Word256) ] foundation-0.0.23/tests/Test/Foundation/String/Base64.hs0000644000000000000000000001260713415353646021165 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Test.Foundation.String.Base64 ( testBase64Refs ) where import Control.Monad import Foundation import Foundation.Numerical import Foundation.String import Foundation.Check testBase64Refs :: Test testBase64Refs = Group "String" [ Group "Base64" testBase64Cases ] testBase64Cases :: [Test] testBase64Cases = [ Group "toBase64" [ Property "length with padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64 $ s) === outputLengthBase64 True blen , Property "valid chars" $ \l -> let s = fromList l s64 = toBase64 s b64 = toBytes UTF8 s64 in all ((||) <$> isPlainBase64Char <*> isPadding) b64 === True , Property "test string: 'pleasure.'" $ do let s = fromList "pleasure." toBase64 s === fromList "cGxlYXN1cmUu" , Property "test string: 'leasure.'" $ do let s = fromList "leasure." toBase64 s === fromList "bGVhc3VyZS4=" , Property "test string: 'easure.'" $ do let s = fromList "easure." toBase64 s === fromList "ZWFzdXJlLg==" , Property "test string: 'asure.'" $ do let s = fromList "asure." toBase64 s === fromList "YXN1cmUu" , Property "test string: 'sure.'" $ do let s = fromList "sure." toBase64 s === fromList "c3VyZS4=" ] , Group "toBase64OpenBSD" [ Property "length without padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64OpenBSD $ s) === outputLengthBase64 False blen , Property "valid chars" $ \l -> let s = fromList l s64 = toBase64OpenBSD s b64 = toBytes UTF8 s64 in all isBase64OpenBSDChar b64 === True ] , Group "toBase64URL" [ Property "length with padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64URL True $ s) === outputLengthBase64 True blen, Property "length without padding" $ \l -> let s = fromList l b = toBytes UTF8 s blen = length b in (length . toBytes UTF8 . toBase64URL False $ s) === outputLengthBase64 False blen , Property "valid chars (with padding)" $ \l -> let s = fromList l s64 = toBase64URL True s b64 = toBytes UTF8 s64 in all ((||) <$> isBase64URLChar <*> isPadding) b64 === True , Property "valid chars (without padding)" $ \l -> let s = fromList l s64 = toBase64URL False s b64 = toBytes UTF8 s64 in all isBase64URLChar b64 === True , Property "test string: 'pleasure.'" $ do let s = fromList "pleasure." toBase64URL False s === fromList "cGxlYXN1cmUu" , Property "test string: 'leasure.'" $ do let s = fromList "leasure." toBase64URL False s === fromList "bGVhc3VyZS4" , Property "test string: ''" $ do let s = fromList "" toBase64URL False s === fromList "" , Property "test string: '\\DC4\\251\\156\\ETX\\217~'" $ do -- the byte list represents "\DC4\251\156\ETX\217~" let s = fromBytesUnsafe . fromList $ [0x14, 0xfb, 0x9c, 0x03, 0xd9, 0x7e] toBase64URL False s === fromList "FPucA9l-" , Property "test string: '\\DC4\\251\\156\\ETX\\217\\DEL'" $ do -- the byte list represents "\DC4\251\156\ETX\217\DEL" let s = fromBytesUnsafe . fromList $ [0x14, 0xfb, 0x9c, 0x03, 0xd9, 0x7f] toBase64URL False s === fromList "FPucA9l_" ] ] outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8 outputLengthBase64 padding (CountOf inputLenInt) = outputLength where outputLength = if padding then CountOf lenWithPadding else CountOf (lenWithPadding - numPadChars) lenWithPadding :: Int lenWithPadding = 4 * roundUp (fromIntegral inputLenInt / 3.0 :: Double) numPadChars :: Int numPadChars = case inputLenInt `mod` 3 of 1 -> 2 2 -> 1 _ -> 0 isPlainBase64Char :: Word8 -> Bool isPlainBase64Char w = isAlphaDigit w || isPlus w || isSlash w isBase64URLChar :: Word8 -> Bool isBase64URLChar w = isAlphaDigit w || isDash w || isUnderscore w isBase64OpenBSDChar :: Word8 -> Bool isBase64OpenBSDChar w = isPeriod w || isSlash w || isAlphaDigit w isPadding :: Word8 -> Bool isPadding w = w == 61 isAlphaDigit :: Word8 -> Bool isAlphaDigit w = isAlpha w || isDigit w isAlpha :: Word8 -> Bool isAlpha w = isUpperAlpha w || isLowerAlpha w isUpperAlpha :: Word8 -> Bool isUpperAlpha w = w - 65 <= 25 isLowerAlpha :: Word8 -> Bool isLowerAlpha w = w - 97 <= 25 isDigit :: Word8 -> Bool isDigit w = w - 48 <= 9 isPlus :: Word8 -> Bool isPlus w = w == 43 isSlash :: Word8 -> Bool isSlash w = w == 47 isDash :: Word8 -> Bool isDash w = w == 45 isUnderscore :: Word8 -> Bool isUnderscore w = w == 95 isPeriod :: Word8 -> Bool isPeriod w = w == 46 foundation-0.0.23/tests/Test/Foundation/String.hs0000644000000000000000000002112613415353646020135 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} module Test.Foundation.String ( testStringRefs ) where -- import Control.Monad (replicateM) import Foundation import Foundation.Check import Foundation.String import Foundation.Primitive (AsciiString) import Test.Data.List import Test.Checks.Property.Collection --import Test.Foundation.Encoding testStringRefs :: Test testStringRefs = Group "String" [ Group "UTF8" $ [ collectionProperties "String" (Proxy :: Proxy String) arbitrary ] <> testStringCases {- <> [ testGroup "Encoding Sample0" (testEncodings sample0) , testGroup "Encoding Sample1" (testEncodings sample1) , testGroup "Encoding Sample2" (testEncodings sample2) ] -} , Group "ASCII" $ [ collectionProperties "AsciiString" (Proxy :: Proxy AsciiString) arbitrary ] -- <> testAsciiStringCases ] testStringCases :: [Test] testStringCases = [ Group "Validation" [ Property "fromBytes . toBytes == valid" $ \l -> let s = fromList l in (fromBytes UTF8 $ toBytes UTF8 s) === (s, Nothing, mempty) , Property "Streaming" $ \(l, randomInts) -> let wholeS = fromList l wholeBA = toBytes UTF8 wholeS reconstruct (prevBa, errs, acc) ba = let ba' = prevBa `mappend` ba (s, merr, nextBa) = fromBytes UTF8 ba' in (nextBa, merr : errs, s : acc) (remainingBa, allErrs, chunkS) = foldl' reconstruct (mempty, [], []) $ chunks randomInts wholeBA in (catMaybes allErrs === []) `propertyAnd` (remainingBa === mempty) `propertyAnd` (mconcat (reverse chunkS) === wholeS) ] , Group "ModifiedUTF8" [ propertyModifiedUTF8 "The foundation Serie" "基地系列" "基地系列" , propertyModifiedUTF8 "has null bytes" "let's\0 do \0 it" "let's\0 do \0 it" , propertyModifiedUTF8 "Vincent's special" "abc\0안, 蠀\0, ☃" "abc\0안, 蠀\0, ☃" , propertyModifiedUTF8 "Long string" "this is only a simple string but quite longer than the 64 bytes used in the modified UTF8 parser" "this is only a simple string but quite longer than the 64 bytes used in the modified UTF8 parser" ] , Group "CaseMapping" [ Property "upper . upper == upper" $ \l -> let s = fromList l in upper (upper s) === upper s , CheckPlan "a should capitalize to A" $ validate "a" $ upper "a" == "A" , CheckPlan "b should capitalize to B" $ validate "b" $ upper "b" == "B" , CheckPlan "B should not capitalize" $ validate "B" $ upper "B" == "B" , CheckPlan "é should capitalize to É" $ validate "é" $ upper "é" == "É" , CheckPlan "ß should capitalize to SS" $ validate "ß" $ upper "ß" == "SS" , CheckPlan "ffl should capitalize to FFL" $ validate "ffl" $ upper "fflfflfflfflfflfflfflfflfflffl" == "FFLFFLFFLFFLFFLFFLFFLFFLFFLFFL" , CheckPlan "0a should capitalize to 0A" $ validate "0a" $ upper "\0a" == "\0A" , CheckPlan "0a should capitalize to 0A" $ validate "0a" $ upper "a\0a" == "A\0A" , CheckPlan "0a should capitalize to 0A" $ validate "0a" $ upper "\0\0" == "\0\0" , CheckPlan "00 should not capitalize" $ validate "00" $ upper "00" == "00" ] {- , testGroup "replace" [ testCase "indices '' 'bb' should raise an error" $ do res <- try (evaluate $ indices "" "bb") case res of (Left (_ :: SomeException)) -> return () Right _ -> fail "Expecting an error to be thrown, but it did not." , testCase "indices 'aa' 'bb' == []" $ do indices "aa" "bb" @?= [] , testCase "indices 'aa' 'aabbccabbccEEaaaaabb' is correct" $ do indices "aa" "aabbccabbccEEaaaaabb" @?= [Offset 0,Offset 13,Offset 15] , testCase "indices 'aa' 'aaccaadd' is correct" $ do indices "aa" "aaccaadd" @?= [Offset 0,Offset 4] , testCase "replace '' 'bb' 'foo' raises an error" $ do (res :: Either SomeException String) <- try (evaluate $ replace "" "bb" "foo") assertBool "Expecting an error to be thrown, but it did not." (isLeft res) , testCase "replace 'aa' 'bb' '' == ''" $ do replace "aa" "bb" "" @?= "" , testCase "replace 'aa' '' 'aabbcc' == 'aabbcc'" $ do replace "aa" "" "aabbcc" @?= "bbcc" , testCase "replace 'aa' 'bb' 'aa' == 'bb'" $ do replace "aa" "bb" "aa" @?= "bb" , testCase "replace 'aa' 'bb' 'aabb' == 'bbbb'" $ do replace "aa" "bb" "aabb" @?= "bbbb" , testCase "replace 'aa' 'bb' 'aaccaadd' == 'bbccbbdd'" $ do replace "aa" "bb" "aaccaadd" @?= "bbccbbdd" , testCase "replace 'aa' 'LongLong' 'aaccaadd' == 'LongLongccLongLongdd'" $ do replace "aa" "LongLong" "aaccaadd" @?= "LongLongccLongLongdd" , testCase "replace 'aa' 'bb' 'aabbccabbccEEaaaaabb' == 'bbbbccabbccEEbbbbabb'" $ do replace "aa" "bb" "aabbccabbccEEaaaaabb" @?= "bbbbccabbccEEbbbbabb" , testCase "replace 'å' 'ä' 'ååññ' == 'ääññ'" $ do replace "å" "ä" "ååññ" @?= "ääññ" ] , testGroup "Cases" [ testGroup "Invalid-UTF8" [ testCase "ff" $ expectFromBytesErr UTF8 ("", Just InvalidHeader, 0) (fromList [0xff]) , testCase "80" $ expectFromBytesErr UTF8 ("", Just InvalidHeader, 0) (fromList [0x80]) , testCase "E2 82 0C" $ expectFromBytesErr UTF8 ("", Just InvalidContinuation, 0) (fromList [0xE2,0x82,0x0c]) , testCase "30 31 E2 82 0C" $ expectFromBytesErr UTF8 ("01", Just InvalidContinuation, 2) (fromList [0x30,0x31,0xE2,0x82,0x0c]) ] ] , testGroup "Lines" [ testCase "HelloFoundation" $ (breakLine "Hello\nFoundation" @?= Right ("Hello", "Foundation")) , testCase "HelloFoundation" $ (breakLine "Hello\r\nFoundation" @?= Right ("Hello", "Foundation")) , testCase "HelloFoundation" $ (breakLine (drop 5 "Hello\nFoundation\nSomething") @?= Right ("", "Foundation\nSomething")) , testCase "Hello" $ (breakLine "Hello\r" @?= Left True) , testCase "CR" $ (breakLine "\r" @?= Left True) , testCase "LF" $ (breakLine "\n" @?= Right ("", "")) , testCase "empty" $ (breakLine "" @?= Left False) ] -} ] {- testAsciiStringCases :: [Test] testAsciiStringCases = [ Group "Validation-ASCII7" [ Property "fromBytes . toBytes == valid" $ \l -> let s = fromList . fromLStringASCII $ l in (fromBytes ASCII7 $ toBytes ASCII7 s) === (s, Nothing, mempty) , Property "Streaming" $ \(l, randomInts) -> let wholeS = fromList . fromLStringASCII $ l wholeBA = toBytes ASCII7 wholeS reconstruct (prevBa, errs, acc) ba = let ba' = prevBa `mappend` ba (s, merr, nextBa) = fromBytes ASCII7 ba' in (nextBa, merr : errs, s : acc) (remainingBa, allErrs, chunkS) = foldl' reconstruct (mempty, [], []) $ chunks randomInts wholeBA in (catMaybes allErrs === []) .&&. (remainingBa === mempty) .&&. (mconcat (reverse chunkS) === wholeS) ] , Group "Cases" [ Group "Invalid-ASCII7" [ testCase "ff" $ expectFromBytesErr ASCII7 ("", Just BuildingFailure, 0) (fromList [0xff]) ] ] ] expectFromBytesErr :: Encoding -> ([Char], Maybe ValidationFailure, CountOf Word8) -> UArray Word8 -> IO () expectFromBytesErr enc (expectedString,expectedErr,positionErr) ba = do let x = fromBytes enc ba (s', merr, ba') = x assertEqual "error" expectedErr merr assertEqual "remaining" (drop positionErr ba) ba' assertEqual "string" expectedString (toList s') -} propertyModifiedUTF8 :: String -> [Char] -> String -> Test propertyModifiedUTF8 name chars str = Property name $ chars === toList str chunks :: Sequential c => RandomList -> c -> [c] chunks (RandomList randomInts) = loop (randomInts <> [1..]) where loop rx c | null c = [] | otherwise = case rx of r:rs -> let (c1,c2) = splitAt (CountOf r) c in c1 : loop rs c2 [] -> loop randomInts c foundation-0.0.23/tests/Test/Foundation/Bits.hs0000644000000000000000000000410013415353646017561 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Test.Foundation.Bits ( tests ) where import Basement.Cast import Foundation.Bits import Foundation.Check import Foundation newtype Shifter = Shifter Int deriving (Show,Eq) instance Arbitrary Shifter where arbitrary = Shifter . applyMod <$> arbitrary where applyMod i = abs i `mod` 256 testBits :: forall a . (Additive a, Bounded a, Difference a ~ a, Integral a, IsIntegral a, Bits a, Show a, Subtractive a, Eq a, Arbitrary a, Typeable a) => String -> Proxy a -> Gen a -> Test testBits n _ _ = Group n [ Property "shiftR" $ \(a :: a) (Shifter i) -> (a `shiftR` i) === convertBack (toInteger a `shiftR` i) , Property "shiftL" $ \(a :: a) (Shifter i) -> (a `shiftL` i) === convertBack (toInteger a `shiftL` i) , Property "maxBound value" $ \(a :: a) -> case bitSizeMaybe a of Just bs -> let actualMaxBound :: a actualMaxBound = maxBound expectedMaxBound :: Integer expectedMaxBound = 2^(cast bs :: Word) - (1 :: Integer) in toInteger actualMaxBound === expectedMaxBound Nothing -> propertyFail "Expected FiniteBits" , Property "complement maxBound" $ complement 0 === (maxBound :: a) , Property "overflow maxBound" $ maxBound + 1 === (0 :: a) , Property "underflow zero" $ (0 :: a) - 1 === maxBound ] where convertBack x | x <= 0 = 0 | otherwise = fromInteger x tests = Group "Bits" {- [ Property "round-up" $ \(Positive m) n' -> n' >= 1 ==> let n = 2 ^ ((n' `mod` 30) :: Word) md = alignRoundUp m n in (md `mod` n) == 0 && md >= m -} [ testBits "W32" (Proxy :: Proxy Word32) arbitrary , testBits "W64" (Proxy :: Proxy Word64) arbitrary , testBits "W128" (Proxy :: Proxy Word128) arbitrary , testBits "W256" (Proxy :: Proxy Word256) arbitrary ] foundation-0.0.23/tests/Test/Basement.hs0000644000000000000000000000037713415353646016324 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Test.Basement ( tests ) where import Foundation import Foundation.Check import qualified Test.Basement.UTF8 as UTF8 tests = Group "basement" [ UTF8.tests ] foundation-0.0.23/tests/Test/Basement/UTF8.hs0000644000000000000000000000066413415353646017051 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} module Test.Basement.UTF8 ( tests ) where import Basement.Types.CharUTF8 import Foundation import Foundation.Check import Foundation.String tests = Group "utf8" [ Property "CharUTF8" $ \c -> decodeCharUTF8 (encodeCharUTF8 c) === c ] foundation-0.0.23/tests/Test/Data/Network.hs0000644000000000000000000000364013415353646017064 0ustar0000000000000000-- | -- Module: -- Author: Nicolas Di Prima -- Date: 2017-01-18T17:34:06+00:00 -- Email: nicolasdiprima@gmail.com -- {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module Test.Data.Network ( genIPv4 , genIPv4Tuple , genIPv4String , genIPv6 , genIPv6Tuple , genIPv6String ) where import Foundation import Foundation.Check import Foundation.Network.IPv4 as IPv4 import Foundation.Network.IPv6 as IPv6 import Foundation.Class.Storable as F import qualified Foreign.Storable as Foreign instance Arbitrary IPv4 where arbitrary = genIPv4 instance Foreign.Storable IPv4 where sizeOf a = let CountOf b = F.size (Just a) in b alignment a = let CountOf b = F.alignment (Just a) in b peek = F.peek poke = F.poke instance Arbitrary IPv6 where arbitrary = genIPv6 instance Foreign.Storable IPv6 where sizeOf a = let CountOf b = F.size (Just a) in b alignment a = let CountOf b = F.alignment (Just a) in b peek = F.peek poke = F.poke genIPv4Tuple :: Gen (Word8, Word8, Word8, Word8) genIPv4Tuple = (,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary genIPv6Tuple :: Gen (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) genIPv6Tuple = (,,,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary genIPv4String :: Gen String genIPv4String = do (w1, w2, w3, w4) <- genIPv4Tuple return $ show w1 <> "." <> show w2 <> "." <> show w3 <> "." <> show w4 genIPv6String :: Gen String genIPv6String = IPv6.toString <$> genIPv6 genIPv6 :: Gen IPv6 genIPv6 = IPv6.fromTuple <$> genIPv6Tuple -- | a better generator for unicode Character genIPv4 :: Gen IPv4 genIPv4 = IPv4.fromTuple <$> genIPv4Tuple foundation-0.0.23/tests/Test/Data/List.hs0000644000000000000000000000234113415353646016343 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module Test.Data.List ( generateListOfElement , generateListOfElementMaxN , generateNonEmptyListOfElement , RandomList(..) ) where import Foundation import Foundation.Collection (nonEmpty_, NonEmpty) import Foundation.Check import Foundation.Monad import Basement.From (from) import Basement.Cast (cast) -- | convenient function to replicate thegiven Generator of `e` a randomly -- choosen amount of time. generateListOfElement :: Gen e -> Gen [e] generateListOfElement = generateListOfElementMaxN 100 -- | convenient function to generate up to a certain amount of time the given -- generator. generateListOfElementMaxN :: CountOf e -> Gen e -> Gen [e] generateListOfElementMaxN n e = replicateBetween 0 (from n) e generateNonEmptyListOfElement :: CountOf e -> Gen e -> Gen (NonEmpty [e]) generateNonEmptyListOfElement n e = nonEmpty_ <$> replicateBetween 1 (from n) e data RandomList = RandomList [Int] deriving (Show,Eq) instance Arbitrary RandomList where arbitrary = RandomList <$> replicateBetween 100 400 (cast <$> between (0,8)) replicateBetween n1 n2 f = between (n1, n2) >>= \n -> replicateM (CountOf (toInt n)) f where toInt :: Word -> Int toInt = cast foundation-0.0.23/tests/Test/Foundation/Network/IPv4.hs0000644000000000000000000000242113415353646021077 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Test.Foundation.Network.IPv4 ( testNetworkIPv4 ) where import Foundation import Foundation.Network.IPv4 import Foundation.Check import Test.Data.Network import Test.Foundation.Storable -- | test property equality for the given Collection testEquality :: Gen IPv4 -> Test testEquality genElement = Group "equality" [ Property "x == x" $ forAll genElement (\x -> x === x) , Property "x == y" $ forAll ((,) <$> genElement <*> genElement) $ \(x,y) -> (toTuple x == toTuple y) === (x == y) ] -- | test ordering testOrdering :: Gen IPv4 -> Test testOrdering genElement = Property "ordering" $ forAll ((,) <$> genElement <*> genElement) $ \(x, y) -> (toTuple x `compare` toTuple y) === x `compare` y testNetworkIPv4 :: Test testNetworkIPv4 = Group "IPv4" [ Property "toTuple . fromTuple == id" $ forAll genIPv4Tuple $ \x -> x === toTuple (fromTuple x) , Property "toString . fromString == id" $ forAll genIPv4String $ \x -> x === toString (fromString $ toList x) , testEquality genIPv4 , testOrdering genIPv4 , testPropertyStorable "Storable" (Proxy :: Proxy IPv4) , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv4) ] foundation-0.0.23/tests/Test/Foundation/Network/IPv6.hs0000644000000000000000000000440313415353646021103 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Test.Foundation.Network.IPv6 ( testNetworkIPv6 ) where import Foundation import Foundation.Check import Foundation.Network.IPv6 import Test.Data.Network import Test.Foundation.Storable -- | test property equality for the given Collection testEquality :: Gen IPv6 -> Test testEquality genElement = Group "equality" [ Property "x == x" $ forAll genElement (\x -> x === x) , Property "x == y" $ forAll ((,) <$> genElement <*> genElement) $ \(x,y) -> (toTuple x == toTuple y) === (x == y) ] -- | test ordering testOrdering :: Gen IPv6 -> Test testOrdering genElement = Property "ordering" $ forAll ((,) <$> genElement <*> genElement) $ \(x, y) -> (toTuple x `compare` toTuple y) === x `compare` y testNetworkIPv6 :: Test testNetworkIPv6 = Group "IPv6" #if __GLASGOW_HASKELL__ >= 710 [ Property "toTuple . fromTuple == id" $ forAll genIPv6Tuple $ \x -> x === toTuple (fromTuple x) , Property "toString . fromString == id" $ forAll genIPv6String $ \x -> x === toString (fromString $ toList x) , testEquality genIPv6 , testOrdering genIPv6 , testPropertyStorable "Storable" (Proxy :: Proxy IPv6) , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv6) , Group "parse" [ Property "::" $ fromTuple (0,0,0,0,0,0,0,0) === fromString "::" , Property "::1" $ fromTuple (0,0,0,0,0,0,0,1) === fromString "::1" , Property "2001:DB8::8:800:200C:417A" $ fromTuple (0x2001,0xDB8,0,0,0x8,0x800,0x200c,0x417a) === fromString "2001:DB8::8:800:200C:417A" , Property "FF01::101" $ fromTuple (0xff01,0,0,0,0,0,0,0x101) === fromString "FF01::101" , Property "::13.1.68.3" $ (fromTuple (0,0,0,0,0,0,0x0d01,0x4403)) === (fromString "::13.1.68.3") , Property "::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "::FFFF:129.144.52.38") , Property "0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0::FFFF:129.144.52.38") , Property "0:0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0:0::FFFF:129.144.52.38") ] ] #else [] #endif foundation-0.0.23/tests/Test/Foundation/Format.hs0000644000000000000000000000036213415353646020116 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Test.Foundation.Format ( testFormat ) where import Foundation import Foundation.Check import Test.Foundation.Format.CSV testFormat :: Test testFormat = Group "Format" [ testFormatCSV ] foundation-0.0.23/tests/Test/Foundation/Format/CSV.hs0000644000000000000000000001146413415353646020556 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.Foundation.Format.CSV ( testFormatCSV ) where import Foundation import Foundation.Format.CSV import Foundation.Check import Foundation.String.Builder (toString) import Foundation.Parser (parseOnly) import Data.Typeable testFormatCSV :: Test testFormatCSV = Group "CSV" [ Group "field unit tests" $ testFieldEncoding <$> fieldUnitTests , Group "row unit tests" $ testRowEncoding <$> rowUnitTests , Group "row unit tests" $ testRowDecoding <$> rowUnitTests , Group "record . toRow == id" [ pTest (Proxy @(Bool, Bool)) , pTest (Proxy @(Int8, Word32, Natural)) , pTest (Proxy @(Int, String, Word256, Word128)) , pTest (Proxy @(Word8, String, Bool, Int64, String)) ] ] where pTest :: (Arbitrary a, Record a, Typeable a, Show a, Eq a) => Proxy a -> Test pTest p = Property (show $ typeRep p) (go p) where go :: (Arbitrary a, Record a, Typeable a, Show a, Eq a) => Proxy a -> a -> PropertyCheck go _ t = let row = (toRow t) str = toString $ rowStringBuilder row in case parseOnly record_ str of Left err -> propertyFail $ show err Right v -> t === v testFieldEncoding (f,r) = Property (show f) $ let str = toString (fieldStringBuilder f) in r === str testRowDecoding (r, row,result) = Property (show r) $ case parseOnly record result of Left err -> propertyFail (show err) Right v -> row === v testRowEncoding (row, _,result) = Property (show row) $ let str = toString (rowStringBuilder row) in result === str fieldUnitTests :: [(Field, String)] fieldUnitTests = [ (FieldInteger 42, "42") , (FieldDouble 1, "1.0") , (FieldDouble 0.000001, "1.0e-6") , (FieldString "String" NoEscape, "String") , (string "String", "String") , (string "with comma,string", "\"with comma,string\"") , (FieldString "multiline\nstring" Escape, "\"multiline\nstring\"") , (FieldString "piece of 12\" by 23\"" DoubleEscape, "\"piece of 12\"\" by 23\"\"\"") , (string "supported sizes are: 12\", 13\" and 14\"", "\"supported sizes are: 12\"\", 13\"\" and 14\"\"\"") ] rowUnitTests :: [(Row, Row, String)] rowUnitTests = [ ( fromList [toField (42 :: Int), toField ("some string" :: String)] , fromList [toField ("42" :: String), toField ("some string" :: String)] , "42,some string" ) , ( toRow (42 :: Int, "some string" :: String) , toRow ("42" :: String, "some string" :: String) , "42,some string" ) , ( toRow ( 42 :: Int , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String ) , toRow ( "42" :: String , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String ) , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\"" ) , ( toRow ( 42 :: Int , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String , Just 0.000001 :: Maybe Double ) , toRow ( "42" :: String , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String , Just "1.0e-6" :: Maybe String ) , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6" ) , ( toRow ( 42 :: Int , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String , Just 0.000001 :: Maybe Double , Nothing :: Maybe Char ) , toRow ( "42" :: String , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String , Just "1.0e-6" :: Maybe String , Nothing :: Maybe String ) , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6," ) , ( toRow ( 42 :: Int , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String , Just 0.000001 :: Maybe Double , Nothing :: Maybe Char , "with £ € ¥" :: String ) , toRow ( "42" :: String , "some string" :: String , "supported sizes are: 12\", 13\" and 14\"" :: String , Just "1.0e-6" :: Maybe String , Nothing :: Maybe String , "with £ € ¥" :: String ) , "42,some string,\"supported sizes are: 12\"\", 13\"\" and 14\"\"\",1.0e-6,,with £ € ¥" ) ] foundation-0.0.23/benchs/Main.hs0000644000000000000000000003321413415353646014627 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module Main where import qualified Prelude import GHC.ST import Foundation import Foundation.Collection import Basement.Block (Block) import Foundation.String.Read import Foundation.String import BenchUtil.Common import BenchUtil.RefData import qualified Basement.Block.Builder as Builder import Sys import LargeWords #ifdef BENCH_ALL import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as ByteString (readInt, readInteger) import qualified Data.Text as Text import qualified Data.Text.Read as Text import qualified Data.Text.Encoding as Text import qualified Data.Vector.Unboxed as Vector #else import qualified Fake.ByteString as ByteString import qualified Fake.Text as Text import qualified Fake.Vector as Vector #endif -------------------------------------------------------------------------- benchsString = bgroup "String" [ benchLength , benchUnpack , benchElem , benchTake , benchSplitAt , benchBuildable , benchReverse , benchFilter , benchRead , benchFromUTF8Bytes , benchUpper , benchLower ] where diffTextString :: (String -> a) -> Maybe (UArray Char -> c) -> (Text.Text -> b) -> [Char] -> [Benchmark] diffTextString foundationBench utf32Bench textBench dat = [ bench "String" $ whnf foundationBench s ] <> maybe [] (\f -> [bench "String-UTF32" $ whnf f ws]) utf32Bench #ifdef BENCH_ALL <> [ bench "Text" $ whnf textBench t ] #endif where s = fromList dat ws = fromList dat t = Text.pack dat diffToTextString :: (UArray Word8 -> String) -> (ByteString.ByteString -> Text.Text) -> [Word8] -> [Benchmark] diffToTextString foundationBench textBench dat = [ bench "String" $ whnf foundationBench s #ifdef BENCH_ALL , bench "Text" $ whnf textBench t #endif ] where s = fromList dat t = ByteString.pack dat diffBsTextString :: (String -> a) -> Maybe (UArray Char -> d) -> (Text.Text -> b) -> (ByteString.ByteString -> c) -> [Char] -> [Benchmark] diffBsTextString foundationBench utf32Bench textBench bytestringBench dat = [ bench "String" $ whnf foundationBench s ] <> maybe [] (\f -> [bench "String-UTF32" $ whnf f ws]) utf32Bench #ifdef BENCH_ALL <> [ bench "Text" $ whnf textBench t , bench "ByteString" $ whnf bytestringBench b ] #endif where s = fromList dat ws = fromList dat t = Text.pack dat b = ByteString.pack $ Prelude.map (fromIntegral . fromEnum) dat allDat :: [(String, [Char])] allDat = [ ("ascii", rdFoundationEn) , ("mascii", rdFoundationHun) , ("uni1" ,rdFoundationJap) , ("uni2" ,rdFoundationZh) ] allDatSuffix s = fmap (first (\x -> x <> "-" <> s)) allDat benchLength = bgroup "Length" $ fmap (\(n, dat) -> bgroup n $ diffTextString length (Just length) Text.length dat) allDat benchUnpack = bgroup "Unpack" $ fmap (\(n, dat) -> bgroup n $ diffTextString (length . toList) (Just (length . toList)) (length . Text.unpack) dat) allDat benchElem = bgroup "Elem" $ fmap (\(n, dat) -> bgroup n $ diffTextString (elem '.') (Just (elem '.')) (Text.any (== '.')) dat) allDat benchTake = bgroup "Take" $ mconcat $ fmap (\p -> fmap (\(n, dat) -> bgroup n $ diffTextString (take (CountOf p)) (Just (take (CountOf p))) (Text.take p) dat) $ allDatSuffix (show p) ) [ 10, 100, 800 ] benchSplitAt = bgroup "SplitAt" $ mconcat $ fmap (\p -> fmap (\(n, dat) -> bgroup n $ diffTextString (fst . splitAt (CountOf p)) (Just ((fst . splitAt (CountOf p)))) (fst . Text.splitAt p) dat) $ allDatSuffix (show p) ) [ 10, 100, 800 ] benchBuildable = bgroup "Buildable" $ fmap (\(n, dat) -> bench n $ toString (\es -> runST $ build_ 128 $ Prelude.mapM_ append es) dat) allDat benchReverse = bgroup "Reverse" $ fmap (\(n, dat) -> bgroup n $ diffTextString reverse (Just reverse) Text.reverse dat) allDat benchFilter = bgroup "Filter" $ fmap (\(n, dat) -> bgroup n $ diffTextString (filter (> 'b')) (Just $ filter (> 'b')) (Text.filter (> 'b')) dat) allDat benchUpper = bgroup "Upper" $ fmap (\(n, dat) -> bgroup n $ diffTextString upper Nothing Text.toUpper dat) (("special casing", rdSpecialCasing) : ("ascii already upper", rdFoundationUpper) : allDat) benchLower = bgroup "Lower" $ fmap (\(n, dat) -> bgroup n $ diffTextString lower Nothing Text.toLower dat) (("special casing", rdSpecialCasing) : ("ascii already lower", rdFoundationLower) : allDat) benchRead = bgroup "Read" [ bgroup "Integer" [ bgroup "10000" (diffTextString stringReadInteger Nothing textReadInteger (toList $ show 10000)) , bgroup "1234567891234567890" (diffTextString stringReadInteger Nothing textReadInteger (toList $ show 1234567891234567890)) ] , bgroup "Int" [ bgroup "12345" (diffBsTextString stringReadInt Nothing textReadInt bsReadInt (toList $ show 12345)) ] , bgroup "Double" [ bgroup "100.56e23" (diffTextString (maybe undefined id . readDouble) Nothing (either undefined fst . Text.double) (toList $ show 100.56e23)) , bgroup "-123.1247" (diffTextString (maybe undefined id . readDouble) Nothing (either undefined fst . Text.double) (toList $ show (-123.1247))) ] ] where bsReadInt :: ByteString.ByteString -> Int bsReadInt = maybe undefined fst . ByteString.readInt textReadInt :: Text.Text -> Int textReadInt = either undefined fst . Text.decimal stringReadInt :: String -> Int stringReadInt = maybe undefined id . readIntegral bsReadInteger :: ByteString.ByteString -> Integer bsReadInteger = maybe undefined fst . ByteString.readInteger textReadInteger :: Text.Text -> Integer textReadInteger = either undefined fst . Text.decimal stringReadInteger :: String -> Integer stringReadInteger = maybe undefined id . readIntegral benchFromUTF8Bytes = bgroup "FromUTF8" $ fmap (\(n, dat) -> bgroup n $ diffToTextString (fst . fromBytes UTF8) (Text.decodeUtf8) dat) (fmap (second (toList . toBytes UTF8 . fromList)) allDat) toString :: ([Char] -> String) -> [Char] -> Benchmarkable toString = whnf -------------------------------------------------------------------------- benchsByteArray = bgroup "ByteArray" [ benchLength , benchTake , benchSplitAt , benchBreakElem , benchTakeWhile , benchFoldl , benchFoldl1 , benchFoldr , benchReverse , benchFilter , benchMonoidConcat , benchBuilderBlock , benchAll , benchSort , benchSort32 ] where diffByteArray :: (UArray Word8 -> a) -> (Block Word8 -> b) -> (ByteString.ByteString -> c) -> (Vector.Vector Word8 -> d) -> [Word8] -> [Benchmark] diffByteArray uarrayBench blockBench bsBench vectorBench dat = [ bench "UArray_W8" $ whnf uarrayBench s , bench "Block_W8" $ whnf blockBench s' #ifdef BENCH_ALL , bench "ByteString" $ whnf bsBench t , bench "Vector_W8" $ whnf vectorBench v #endif ] where s = fromList dat s' = fromList dat t = ByteString.pack dat v = Vector.fromList dat diffListByteArray :: ([UArray Word8] -> a) -> ([Block Word8] -> b) -> ([ByteString.ByteString] -> c) -> ([Vector.Vector Word8] -> d) -> [[Word8]] -> [Benchmark] diffListByteArray uarrayBench blockBench bsBench vectorBench dat = [ bench "[UArray_W8]" $ whnf uarrayBench s , bench "[Block_W8]" $ whnf blockBench s' #ifdef BENCH_ALL , bench "[ByteString]" $ whnf bsBench t , bench "[Vector_W8]" $ whnf vectorBench v #endif ] where s = fromList <$> dat s' = fromList <$> dat t = ByteString.pack <$> dat v = Vector.fromList <$> dat allDat = [ ("bs20", rdBytes20) , ("bs200", rdBytes200) , ("bs2000", rdBytes2000) ] allListDat = [ ("listBs20", Prelude.replicate 20 rdBytes20) , ("listBs200", Prelude.replicate 200 rdBytes200) , ("listBs2000", Prelude.replicate 2000 rdBytes2000) ] allDatSuffix s = fmap (first (\x -> x <> "-" <> s)) allDat benchLength = bgroup "Length" $ fmap (\(n, dat) -> bgroup n $ diffByteArray length length ByteString.length Vector.length dat) allDat benchTake = bgroup "Take" $ mconcat $ fmap (\p -> fmap (\(n, dat) -> bgroup n $ diffByteArray (take (CountOf p)) (take (CountOf p)) (ByteString.take p) (Vector.take p) dat) $ allDatSuffix (show p) ) [ 0, 10, 100 ] benchSplitAt = bgroup "SplitAt" $ mconcat $ fmap (\p -> fmap (\(n, dat) -> bgroup n $ diffByteArray (fst . splitAt (CountOf p)) (fst . splitAt (CountOf p)) (fst . ByteString.splitAt p) (fst . Vector.splitAt p) dat) $ allDatSuffix (show p) ) [ 19, 199, 0 ] benchBreakElem = bgroup "BreakElem" $ mconcat $ fmap (\p -> fmap (\(n, dat) -> bgroup n $ diffByteArray (fst . breakElem p) (fst . breakElem p) (fst . ByteString.break (== p)) (fst . Vector.break (== p)) dat) $ allDatSuffix (show p) ) [ 19, 199, 0 ] benchTakeWhile = bgroup "TakeWhile" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (takeWhile (< 0x80)) (takeWhile (< 0x80)) (ByteString.takeWhile (< 0x80)) (Vector.takeWhile (< 0x80)) dat) $ allDat benchFoldl = bgroup "Foldl" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (foldl' (+) 0) (foldl' (+) 0) (ByteString.foldl' (+) 0) (Vector.foldl' (+) 0) dat) $ allDat benchFoldl1 = bgroup "Foldl1" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (foldl1' (+) . nonEmpty_) (foldl1' (+) . nonEmpty_) (ByteString.foldl1' (+)) (Vector.foldl1' (+)) dat) $ allDat benchFoldr = bgroup "Foldr" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (foldr (+) 1) (foldr (+) 1) (ByteString.foldr (+) 1) (Vector.foldr (+) 1) dat) $ allDat benchAll = bgroup "All" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (all (> 0)) (all (> 0)) (ByteString.all (> 0)) (Vector.all (> 0)) dat) $ allDat benchAny = bgroup "Any" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (any (== 80)) (any (== 80)) (ByteString.any (== 80)) (Vector.any (== 80)) dat) $ allDat benchReverse = bgroup "Reverse" $ fmap (\(n, dat) -> bgroup n $ diffByteArray reverse reverse ByteString.reverse Vector.reverse dat) allDat benchFilter = bgroup "Filter" $ fmap (\(n, dat) -> bgroup n $ diffByteArray (filter (> 100)) (filter (> 100)) (ByteString.filter (> 100)) (Vector.filter (> 100)) dat) allDat benchMonoidConcat = bgroup "Monoid/mconcat" $ fmap (\(n, dat) -> bgroup n $ diffListByteArray mconcat mconcat ByteString.concat Vector.concat dat) allListDat benchBuilderBlock = bgroup "Monoid/builder" $ [ bench "[block Word8]" $ whnf builderConcat (Prelude.replicate 2000 (fromList rdBytes2000)) ] where builderConcat :: [Block Word8] -> Block Word8 builderConcat l = runST $ Builder.run $ mconcat (fmap Builder.emit l) benchSort = bgroup "Sort" $ fmap (\(n, dat) -> bgroup n $ [ bench "UArray_W8" $ whnf uarrayBench (fromList dat) , bench "Block_W8" $ whnf blockBench (fromList dat) ]) allDat where blockBench :: Block Word8 -> Block Word8 blockBench dat = sortBy compare dat uarrayBench :: UArray Word8 -> UArray Word8 uarrayBench dat = sortBy compare dat benchSort32 = bgroup "Sort32" $ fmap (\n -> bgroup (show n) $ [ bench "Array_W32" $ whnf arrayBench (fromList $ rdWord32 n) , bench "UArray_W32" $ whnf uarrayBench (fromList $ rdWord32 n) , bench "Block_W32" $ whnf blockBench (fromList $ rdWord32 n) ]) [20, 200, 2000] where blockBench :: Block Word32 -> Block Word32 blockBench dat = sortBy compare dat uarrayBench :: UArray Word32 -> UArray Word32 uarrayBench dat = sortBy compare dat arrayBench :: Array Word32 -> Array Word32 arrayBench dat = sortBy compare dat -------------------------------------------------------------------------- benchsTypes = bgroup "types" [ benchsString , benchsByteArray ] main = defaultMain [ benchsTypes , bgroup "Sys" benchSys , bgroup "LargeWord" benchLargeWords ] foundation-0.0.23/benchs/BenchUtil/Common.hs0000644000000000000000000000102613415353646017044 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module BenchUtil.Common ( defaultMain , Benchmark , Benchmarkable , bgroup , bench , fbench , whnf , whnfIO , nf ) where import Gauge.Main hiding (bgroup, bench) import qualified Gauge.Main as C import Foundation fbench = bench "foundation" bgroup :: String -> [Benchmark] -> Benchmark bgroup n f = C.bgroup (toList n) f bench :: String -> Benchmarkable -> Benchmark bench n f = C.bench (toList n) f foundation-0.0.23/benchs/BenchUtil/RefData.hs0000644000000000000000000002316213415353646017127 0ustar0000000000000000module BenchUtil.RefData ( -- string rdLoremIpsum1 , rdLoremIpsum5 , rdFoundationEn , rdFoundationZh , rdFoundationJap , rdFoundationHun , rdFoundationLower , rdFoundationUpper , rdSpecialCasing -- byte array , rdBytes20 , rdBytes200 , rdBytes2000 , rdWord32 ) where import Prelude (Int, Char, cycle, take, ($)) import Data.Word (Word8, Word32) rdLoremIpsum1 :: [Char] rdLoremIpsum1 = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam ornare dui vitae porta varius. In quis diam sed felis elementum ultricies non sit amet lorem. Nullam ut erat varius lectus scelerisque iaculis sed eu leo. Vivamus gravida interdum elit suscipit tempus. Quisque at mauris ac sapien consequat feugiat. In varius interdum rhoncus. Etiam hendrerit pharetra consectetur. Pellentesque laoreet, nisi quis feugiat rhoncus, nisi ipsum tincidunt nulla, vel fermentum mauris nisl sed felis. Sed ac convallis nibh. Donec rutrum finibus odio et rhoncus. Suspendisse pulvinar ex ac fermentum fermentum. Nam dui dui, lobortis sit amet sapien sed, gravida sagittis magna. Vestibulum nec egestas dui, non efficitur lectus. Fusce vitae mattis sem, nec dignissim nibh. Sed ac tincidunt metus." rdLoremIpsum5 :: [Char] rdLoremIpsum5 = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam ornare dui vitae porta varius. In quis diam sed felis elementum ultricies non sit amet lorem. Nullam ut erat varius lectus scelerisque iaculis sed eu leo. Vivamus gravida interdum elit suscipit tempus. Quisque at mauris ac sapien consequat feugiat. In varius interdum rhoncus. Etiam hendrerit pharetra consectetur. Pellentesque laoreet, nisi quis feugiat rhoncus, nisi ipsum tincidunt nulla, vel fermentum mauris nisl sed felis. Sed ac convallis nibh. Donec rutrum finibus odio et rhoncus. Suspendisse pulvinar ex ac fermentum fermentum. Nam dui dui, lobortis sit amet sapien sed, gravida sagittis magna. Vestibulum nec egestas dui, non efficitur lectus. Fusce vitae mattis sem, nec dignissim nibh. Sed ac tincidunt metus. Vestibulum ac bibendum ex. In vulputate pellentesque elementum. Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos himenaeos. Maecenas elit libero, vehicula eget hendrerit non, convallis vel metus. Maecenas faucibus nulla id quam vestibulum, eget commodo tellus interdum. Mauris eu odio id lacus gravida sollicitudin. Aenean vel velit enim. Phasellus vitae urna nisl. Interdum et malesuada fames ac ante ipsum primis in faucibus. Nunc volutpat convallis elementum. Curabitur suscipit congue ligula non maximus. Fusce tristique lacinia sem sed condimentum. Sed non eleifend mi, fringilla congue tortor. Nunc rhoncus sit amet nisl ac tempor. Fusce sed consectetur purus, et aliquam sem. Vestibulum finibus lectus et vehicula euismod. Aliquam sed neque mattis, sollicitudin enim sed, vestibulum est. Quisque varius pharetra risus id tempor. In hac habitasse platea dictumst. Donec cursus nisi sed magna bibendum aliquet. Mauris a elit id erat imperdiet consequat. Phasellus at condimentum ipsum. Pellentesque vehicula pulvinar ipsum et porta. Nullam quis quam mauris. Sed scelerisque porta nibh eu tempor. Morbi sollicitudin fringilla sollicitudin. Cras nec velit quis velit sollicitudin pellentesque. Phasellus quis ullamcorper nisi. Curabitur fringilla sed turpis sit amet pharetra. Cras euismod eget massa eu posuere. Suspendisse id aliquam enim. Nullam sollicitudin aliquet elementum. Nulla sit amet ligula vitae lorem finibus laoreet sed ac velit. Nulla facilisi. Aenean vel pretium lectus. Nunc augue lorem, viverra et felis vel, vestibulum feugiat nisl. Vestibulum imperdiet laoreet posuere. Maecenas vestibulum consequat felis eu aliquam. Nullam ac efficitur ante, eget egestas mauris. Cras id tincidunt nisi. Cras tincidunt molestie lorem et bibendum. Donec commodo porttitor faucibus. Aenean aliquam suscipit iaculis. Cras eu purus sit amet elit rhoncus laoreet. Vestibulum fringilla nulla ut neque vestibulum porttitor. Pellentesque vitae risus elit. Quisque et sapien eu diam tincidunt luctus ac quis nunc. Proin nec nisl eget diam faucibus tempus id sed quam. Ut scelerisque enim lacus, at mollis diam sagittis et. Nam lobortis convallis maximus. Donec maximus tortor id consequat venenatis." rdFoundationEn :: [Char] rdFoundationEn = "Set in the year 0 F.E. (\"Foundation Era\"), The Psychohistorians opens on Trantor, the capital of the 12,000-year-old Galactic Empire. Though the empire appears stable and powerful, it is slowly decaying in ways that parallel the decline of the Western Roman Empire. Hari Seldon, a mathematician and psychologist, has developed psychohistory, a new field of science and psychology that equates all possibilities in large societies to mathematics, allowing for the prediction of future events." rdFoundationLower :: [Char] rdFoundationLower = "set in the year 0 f.e. (\"foundation era\"), the psychohistorians opens on trantor, the capital of the 12,000-year-old galactic empire. though the empire appears stable and powerful, it is slowly decaying in ways that parallel the decline of the western roman empire. hari seldon, a mathematician and psychologist, has developed psychohistory, a new field of science and psychology that equates all possibilities in large societies to mathematics, allowing for the prediction of future events." rdFoundationUpper :: [Char] rdFoundationUpper = "SET IN THE YEAR 0 F.E. (\"FOUNDATION ERA\"), THE PSYCHOHISTORIANS OPENS ON TRANTOR, THE CAPITAL OF THE 12,000-YEAR-OLD GALACTIC EMPIRE. THOUGH THE EMPIRE APPEARS STABLE AND POWERFUL, IT IS SLOWLY DECAYING IN WAYS THAT PARALLEL THE DECLINE OF THE WESTERN ROMAN EMPIRE. HARI SELDON, A MATHEMATICIAN AND PSYCHOLOGIST, HAS DEVELOPED PSYCHOHISTORY, A NEW FIELD OF SCIENCE AND PSYCHOLOGY THAT EQUATES ALL POSSIBILITIES IN LARGE SOCIETIES TO MATHEMATICS, ALLOWING FOR THE PREDICTION OF FUTURE EVENTS." rdFoundationZh :: [Char] rdFoundationZh = "故事發生在〈心理史學家〉五十年後，端點星面臨首度的「謝頓危機」（Seldon Crisis）銀河帝國邊緣的星群紛紛獨立起來，端點星處於四個王國之間，備受威脅。此時，謝頓早前錄下影像突然播放，告知他的後人端點星「銀河百科全書第一號基地」的真正目的──在千年後建立一個新的銀河帝國。同時，在這一千年間，基地會遇到各種不同的危機，令基地可以急速成長。端點星市長塞佛·哈定（Salvor Hardin）趁機發動政變，從心神未定的百科全書理事會手中奪權，以他靈活的手腕帶領端點星走出危機。" rdFoundationHun :: [Char] rdFoundationHun = "A történet G.K. 12 067-ben (A.K. 1) játszódik. A fiatal és tehetséges matematikus, Gaal Dornick a Trantorra, a Galaktikus Birodalom központi bolygójára tart, hogy csatlakozzon egy tekintélyes matematikus, I. Cleon császár egykori első minisztere, Hari Seldon tervezetéhez, a Seldon-tervhez. Gaal nem sokat tud a terv mibenlétéről, ám Seldon személyes meghívásának hatására a Trantorra indul. Megérkezése után nem sokkal találkozik Seldonnal, aki elmondja neki, hogy a tervet és az azzal kapcsolatba hozható személyeket – így őt is – a Közbiztonsági Bizottság – a Birodalomban a császárral szemben a tényleges hatalmat gyakorló testület –, szigorú megfigyelés alatt tart. Seldon beszél Gaal-nak a terv néhány részletéről, és megemlíti, hogy Trantor a pszichohistóriai számítások szerint 500 éven belül elpusztul. Találkozásuk másnapján Gaal-t és Seldon-t is letartóztatják." rdFoundationJap :: [Char] rdFoundationJap = "数学者ハリ・セルダンは、膨大な集団の行動を予測する心理歴史学を作りあげ発展させることで、銀河帝国が近いうちに崩壊することを予言する[1]。セルダンは、帝国崩壊後に3万年続くはずの暗黒時代を、あらゆる知識を保存することで千年に縮めようとし、知識の集大成となる銀河百科事典 (Encyclopedia Galactica) を編纂するグループ「ファウンデーション」をつくったが、帝国崩壊を公言し平和を乱したという罪で裁判にかけられ、グループは銀河系辺縁部にある資源の乏しい無人惑星ターミナスへ追放されることになった。しかし、この追放劇すらもセルダンの計画に予定されていた事柄であった。病で死期をさとっていたセルダンは、己の仕事が終わったことを確信する。" rdSpecialCasing :: [Char] rdSpecialCasing = "fflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflfflffl" rdBytes20 ::[Word8] rdBytes20 = take 20 $ cycle [1..255] rdBytes200 :: [Word8] rdBytes200 = take 200 $ cycle [1..255] rdBytes2000 :: [Word8] rdBytes2000 = take 2000 $ cycle [1..255] rdWord32 :: Int -> [Word32] rdWord32 n = Prelude.take n $ Prelude.cycle [1..255] foundation-0.0.23/benchs/Sys.hs0000644000000000000000000000254213415353646014521 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE OverloadedStrings #-} module Sys ( benchSys ) where import Foundation import Foundation.Collection import BenchUtil.Common import BenchUtil.RefData import Foundation.System.Entropy import Foundation.Random import qualified Prelude data NullRandom = NullRandom instance RandomGen NullRandom where randomNew = return NullRandom randomNewFrom = error "no randomNewFrom" randomGenerate (CountOf n) r = (fromList (Prelude.replicate n 0), r) randomGenerateWord64 r = (0, r) randomGenerateF32 r = (0.0, r) randomGenerateF64 r = (0.0, r) benchSys = [ bgroup "Random" [ bench "Entropy-1" $ whnfIO $ getEntropy 1 , bench "Entropy-16" $ whnfIO $ getEntropy 16 , 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 (CountOf (1024 * 1024)) randomNew (Proxy :: Proxy RNGv1) ] ] benchRandom :: RandomGen rng => CountOf Word8 -> MonadRandomState NullRandom rng -> Proxy rng -> Benchmarkable benchRandom n rNew _ = whnf (fst . randomGenerate n) (fst $ withRandomGenerator NullRandom rNew) foundation-0.0.23/benchs/LargeWords.hs0000644000000000000000000000270513415353646016015 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module LargeWords where import Foundation import Basement.From import Basement.Types.Word128 (Word128) import Basement.Types.Word256 (Word256) import qualified Basement.Types.Word128 as Word128 import qualified Basement.Types.Word256 as Word256 import BenchUtil.Common largeNumber64 :: Natural largeNumber64 = 0xffffffffffffffff largeNumber128 :: Natural largeNumber128 = 0xfffffffffffffffffffffffffffffff largeNumber256 :: Natural largeNumber256 = 0xffffffffffffffffffffffffffffffffffffffffffffffff benchLargeWords = [ bgroup "Addition" [ bgroup "Word128" [ bench "Word128" $ whnf (+ 1240) (Word128.fromNatural largeNumber128) , bench "Natural" $ whnf (+ 1240) largeNumber128 ] , bgroup "Word256" [ bench "Word256" $ whnf (+ 200) (Word256.fromNatural largeNumber256) , bench "Natural" $ whnf (+ 200) largeNumber256 ] ] , bgroup "Multiplication" [ bgroup "Word128" [ bench "Word128" $ whnf (* 1240) (Word128.fromNatural largeNumber128) , bench "Natural" $ whnf (* 1240) largeNumber128 ] , bgroup "Word256" [ bench "Word256" $ whnf (* 200) (Word256.fromNatural largeNumber256) , bench "Natural" $ whnf (* 200) largeNumber256 ] ] ] foundation-0.0.23/benchs/Fake/ByteString.hs0000644000000000000000000000214213415353646016677 0ustar0000000000000000module Fake.ByteString ( ByteString , pack , length , splitAt , take , takeWhile , break , reverse , filter , foldl' , foldl1' , foldr , and , all , any , readInt , readInteger , unpack , concat ) where import Prelude (undefined, Maybe(..)) import Data.Word data ByteString = ByteString pack _ = ByteString length = undefined splitAt _ _ = (undefined, undefined) take = undefined break _ _ = (undefined, undefined) takeWhile _ _ = undefined reverse = undefined filter _ = undefined foldl' :: (Word8 -> a -> a) -> a -> ByteString -> a foldl' _ _ _ = undefined foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> a foldl1' _ _ = undefined foldr :: (a -> Word8 -> a) -> a -> ByteString -> a foldr _ _ _ = undefined and _ _ = undefined all _ _ = undefined any _ _ = undefined concat :: [ByteString] -> ByteString concat _ = undefined unpack :: ByteString -> [Word8] unpack = undefined readInt :: ByteString -> Maybe (a,b) readInt _ = undefined readInteger :: ByteString -> Maybe (a,b) readInteger _ = undefined foundation-0.0.23/benchs/Fake/Text.hs0000644000000000000000000000125013415353646015530 0ustar0000000000000000module Fake.Text ( Text , pack , unpack , length , splitAt , take , any , filter , reverse , decimal , double , decodeUtf8 , toLower , toUpper ) where import Prelude (undefined, Either(..), Char) data Text = Text pack _ = Text unpack :: Text -> [Char] unpack _ = undefined length = undefined splitAt _ _ = (undefined, undefined) take = undefined filter _ = undefined reverse = undefined any = undefined decodeUtf8 = undefined toLower = undefined toUpper = undefined decimal :: Text -> Either a (b, c) decimal = undefined double :: Text -> Either a (b, c) double = undefined foundation-0.0.23/benchs/Fake/Vector.hs0000644000000000000000000000153413415353646016053 0ustar0000000000000000module Fake.Vector ( Vector , fromList , toList , length , splitAt , take , takeWhile , break , reverse , filter , foldl' , foldl1' , foldr , and , all , any , concat ) where import Prelude (undefined) data Vector ty = Vector fromList _ = Vector toList :: Vector ty -> [ty] toList _ = undefined length = undefined splitAt _ _ = (undefined, undefined) take = undefined break _ _ = (undefined, undefined) takeWhile _ _ = undefined reverse = undefined filter _ = undefined foldl' :: (ty -> a -> a) -> a -> Vector ty -> a foldl' _ _ _ = undefined foldl1' :: (ty -> ty -> ty) -> Vector ty -> a foldl1' _ _ = undefined foldr :: (a -> ty -> a) -> a -> Vector ty -> a foldr _ _ _ = undefined and _ _ = undefined all _ _ = undefined any _ _ = undefined concat = undefined foundation-0.0.23/LICENSE0000644000000000000000000000300613415353646013146 0ustar0000000000000000Copyright (c) 2015-2017 Vincent Hanquez Copyright (c) 2017-2018 Foundation Maintainers All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. foundation-0.0.23/foundation.cabal0000644000000000000000000002660713426501561015300 0ustar0000000000000000name: foundation version: 0.0.23 synopsis: Alternative prelude with batteries and no dependencies description: A custom prelude with no dependencies apart from base. . This package has the following goals: . * provide a base like sets of modules that provide a consistent set of features and bugfixes across multiple versions of GHC (unlike base). . * provide a better and more efficient prelude than base's prelude. . * be self-sufficient: no external dependencies apart from base. . * provide better data-types: packed unicode string by default, arrays. . * Better numerical classes that better represent mathematical thing (No more all-in-one Num). . * Better I/O system with less Lazy IO . * Usual partial functions distinguished through type system license: BSD3 license-file: LICENSE copyright: 2015-2017 Vincent Hanquez , 2017- Foundation Maintainers author: Vincent Hanquez maintainer: vincent@snarc.org category: foundation build-type: Simple homepage: https://github.com/haskell-foundation/foundation bug-reports: https://github.com/haskell-foundation/foundation/issues cabal-version: >=1.18 extra-source-files: cbits/*.h source-repository head type: git location: https://github.com/haskell-foundation/foundation subdir: foundation flag experimental description: Enable building experimental features, known as highly unstable or without good support cross-platform default: False manual: True flag bench-all description: Add some comparaison benchmarks against other haskell libraries default: False manual: True flag minimal-deps description: Build fully with minimal deps (no criterion, no quickcheck, no doctest) default: False manual: True flag bounds-check description: Add extra friendly boundary check for unsafe array operations default: False manual: True flag doctest description: Build doctest on demand only default: False manual: True flag linktest description: Run linking test default: False manual: True library exposed-modules: Foundation Foundation.Numerical Foundation.Array Foundation.Array.Internal Foundation.Bits Foundation.Class.Bifunctor Foundation.Class.Storable Foundation.Conduit Foundation.Conduit.Textual Foundation.Exception Foundation.Format.CSV Foundation.String Foundation.String.Read Foundation.String.Builder Foundation.IO Foundation.IO.FileMap Foundation.IO.Terminal Foundation.VFS Foundation.VFS.Path Foundation.VFS.FilePath Foundation.VFS.URI Foundation.Math.Trigonometry Foundation.Hashing Foundation.Foreign Foundation.Collection Foundation.Primitive Foundation.List.DList Foundation.List.ListN Foundation.Monad Foundation.Monad.Except Foundation.Monad.Reader Foundation.Monad.State Foundation.Network.IPv4 Foundation.Network.IPv6 Foundation.System.Info Foundation.Strict Foundation.Parser Foundation.Random Foundation.Check Foundation.Check.Main Foundation.Timing Foundation.Timing.Main Foundation.Time.Types Foundation.Time.Bindings Foundation.Time.StopWatch Foundation.Tuple.Nth Foundation.UUID Foundation.System.Entropy Foundation.System.Bindings other-modules: Foundation.Tuple Foundation.Hashing.FNV Foundation.Hashing.SipHash Foundation.Hashing.Hasher Foundation.Hashing.Hashable Foundation.Check.Gen Foundation.Check.Print Foundation.Check.Arbitrary Foundation.Check.Property Foundation.Check.Config Foundation.Check.Types Foundation.Collection.Buildable Foundation.Collection.List Foundation.Collection.Element Foundation.Collection.InnerFunctor Foundation.Collection.Collection Foundation.Collection.Copy Foundation.Collection.Sequential Foundation.Collection.Keyed Foundation.Collection.Indexed Foundation.Collection.Foldable Foundation.Collection.Mutable Foundation.Collection.Zippable Foundation.Collection.Mappable Foundation.Conduit.Internal Foundation.Format.CSV.Types Foundation.Format.CSV.Builder Foundation.Format.CSV.Parser Foundation.Numerical.Floating Foundation.IO.File Foundation.Monad.MonadIO Foundation.Monad.Exception Foundation.Monad.Transformer Foundation.Monad.Identity Foundation.Monad.Base Foundation.Random.Class Foundation.Random.DRG Foundation.Random.ChaChaDRG Foundation.Random.XorShift Foundation.Array.Chunked.Unboxed Foundation.Array.Bitmap Foundation.Foreign.Alloc Foundation.Foreign.MemoryMap Foundation.Foreign.MemoryMap.Types Foundation.Partial -- Foundation.Time.Bindings Foundation.System.Entropy.Common Foundation.System.Bindings.Network Foundation.System.Bindings.Time Foundation.System.Bindings.Hs include-dirs: cbits c-sources: cbits/foundation_random.c cbits/foundation_network.c cbits/foundation_time.c cbits/foundation_utf8.c if flag(experimental) exposed-modules: Foundation.Network.HostName if os(windows) exposed-modules: Foundation.System.Bindings.Windows other-modules: Foundation.Foreign.MemoryMap.Windows Foundation.System.Entropy.Windows else exposed-modules: Foundation.System.Bindings.Posix Foundation.System.Bindings.PosixDef other-modules: Foundation.Foreign.MemoryMap.Posix Foundation.System.Entropy.Unix if os(linux) exposed-modules: Foundation.System.Bindings.Linux if os(osx) exposed-modules: Foundation.System.Bindings.Macos default-extensions: NoImplicitPrelude RebindableSyntax TypeFamilies BangPatterns DeriveDataTypeable if impl(ghc < 8.0) buildable: False else build-depends: base , ghc-prim if os(windows) build-depends: Win32 if arch(i386) extra-libraries: gcc build-depends: basement == 0.0.10 -- FIXME add suport for armel mipsel -- CPP-options: -DARCH_IS_LITTLE_ENDIAN -- FIXME add support for powerpc powerpc64 armeb mipseb -- CPP-options: -DARCH_IS_BIG_ENDIAN if (arch(i386) || arch(x86_64)) cpp-options: -DARCH_IS_LITTLE_ENDIAN else cpp-options: -DARCH_IS_UNKNOWN_ENDIAN ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 if impl(ghc >= 8.0) ghc-options: -Wno-redundant-constraints if flag(bounds-check) cpp-options: -DFOUNDATION_BOUNDS_CHECK test-suite check-foundation type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Checks.hs other-modules: Test.Checks.Property.Collection Test.Foundation.Random Test.Foundation.Misc Test.Foundation.Conduit Test.Foundation.Primitive.BlockN Test.Foundation.Storable Test.Foundation.Number Test.Foundation.String.Base64 Test.Foundation.String Test.Foundation.Bits Test.Basement Test.Basement.UTF8 Test.Data.Network Test.Data.List Test.Foundation.Network.IPv4 Test.Foundation.Network.IPv6 Test.Foundation.Format Test.Foundation.Format.CSV default-extensions: NoImplicitPrelude RebindableSyntax OverloadedStrings build-depends: base > 0 && < 1000 , basement , 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 foundation-link type: exitcode-stdio-1.0 hs-source-dirs: tests default-language: Haskell2010 main-is: Scripts/Link.hs default-extensions: NoImplicitPrelude RebindableSyntax if flag(linktest) build-depends: base > 0 && < 1000 , foundation , template-haskell buildable: True else buildable: False test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: tests default-language: Haskell2010 main-is: DocTest.hs default-extensions: NoImplicitPrelude RebindableSyntax if flag(minimal-deps) -- TODO: for no, force unbuildable anyway buildable: False else if flag(doctest) build-depends: base , doctest >= 0.9 buildable: True else buildable: False Benchmark bench main-is: Main.hs other-modules: BenchUtil.Common BenchUtil.RefData Sys LargeWords Fake.ByteString Fake.Text Fake.Vector hs-source-dirs: benchs default-language: Haskell2010 type: exitcode-stdio-1.0 default-extensions: NoImplicitPrelude BangPatterns if flag(minimal-deps) || impl(ghc < 7.10) buildable: False else build-depends: base, gauge, basement, foundation if flag(bench-all) cpp-options: -DBENCH_ALL build-depends: text, attoparsec, vector, bytestring foundation-0.0.23/cbits/foundation_bits.h0000644000000000000000000001570113415353646016612 0ustar0000000000000000/* * Copyright (C) 2006-2014 Vincent Hanquez * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #ifndef BITFN_H #define BITFN_H #include #ifndef NO_INLINE_ASM /**********************************************************/ # if (defined(__i386__)) # define ARCH_HAS_SWAP32 static inline uint32_t bitfn_swap32(uint32_t a) { asm ("bswap %0" : "=r" (a) : "0" (a)); return a; } /**********************************************************/ # elif (defined(__arm__)) # define ARCH_HAS_SWAP32 static inline uint32_t bitfn_swap32(uint32_t a) { uint32_t tmp = a; asm volatile ("eor %1, %0, %0, ror #16\n" "bic %1, %1, #0xff0000\n" "mov %0, %0, ror #8\n" "eor %0, %0, %1, lsr #8\n" : "=r" (a), "=r" (tmp) : "0" (a), "1" (tmp)); return a; } /**********************************************************/ # elif defined(__x86_64__) # define ARCH_HAS_SWAP32 # define ARCH_HAS_SWAP64 static inline uint32_t bitfn_swap32(uint32_t a) { asm ("bswap %0" : "=r" (a) : "0" (a)); return a; } static inline uint64_t bitfn_swap64(uint64_t a) { asm ("bswap %0" : "=r" (a) : "0" (a)); return a; } # endif #endif /* NO_INLINE_ASM */ /**********************************************************/ #ifndef ARCH_HAS_ROL32 static inline uint32_t rol32(uint32_t word, uint32_t shift) { return (word << shift) | (word >> (32 - shift)); } #endif #ifndef ARCH_HAS_ROR32 static inline uint32_t ror32(uint32_t word, uint32_t shift) { return (word >> shift) | (word << (32 - shift)); } #endif #ifndef ARCH_HAS_ROL64 static inline uint64_t rol64(uint64_t word, uint32_t shift) { return (word << shift) | (word >> (64 - shift)); } #endif #ifndef ARCH_HAS_ROR64 static inline uint64_t ror64(uint64_t word, uint32_t shift) { return (word >> shift) | (word << (64 - shift)); } #endif #ifndef ARCH_HAS_SWAP32 static inline uint32_t bitfn_swap32(uint32_t a) { return (a << 24) | ((a & 0xff00) << 8) | ((a >> 8) & 0xff00) | (a >> 24); } #endif #ifndef ARCH_HAS_ARRAY_SWAP32 static inline void array_swap32(uint32_t *d, uint32_t *s, uint32_t nb) { while (nb--) *d++ = bitfn_swap32(*s++); } #endif #ifndef ARCH_HAS_SWAP64 static inline uint64_t bitfn_swap64(uint64_t a) { return ((uint64_t) bitfn_swap32((uint32_t) (a >> 32))) | (((uint64_t) bitfn_swap32((uint32_t) a)) << 32); } #endif #ifndef ARCH_HAS_ARRAY_SWAP64 static inline void array_swap64(uint64_t *d, uint64_t *s, uint32_t nb) { while (nb--) *d++ = bitfn_swap64(*s++); } #endif #ifndef ARCH_HAS_MEMORY_ZERO static inline void memory_zero(void *ptr, uint32_t len) { uint32_t *ptr32 = ptr; uint8_t *ptr8; int i; for (i = 0; i < len / 4; i++) *ptr32++ = 0; if (len % 4) { ptr8 = (uint8_t *) ptr32; for (i = len % 4; i >= 0; i--) ptr8[i] = 0; } } #endif #ifndef ARCH_HAS_ARRAY_COPY32 static inline void array_copy32(uint32_t *d, uint32_t *s, uint32_t nb) { while (nb--) *d++ = *s++; } #endif #ifndef ARCH_HAS_ARRAY_XOR32 static inline void array_xor32(uint32_t *d, uint32_t *s, uint32_t nb) { while (nb--) *d++ ^= *s++; } #endif #ifndef ARCH_HAS_ARRAY_COPY64 static inline void array_copy64(uint64_t *d, uint64_t *s, uint32_t nb) { while (nb--) *d++ = *s++; } #endif #ifdef __GNUC__ #define bitfn_ntz(n) __builtin_ctz(n) #else #error "define ntz for your platform" #endif #ifdef __MINGW32__ # define LITTLE_ENDIAN 1234 # define BYTE_ORDER LITTLE_ENDIAN #elif defined(__FreeBSD__) || defined(__DragonFly__) || defined(__NetBSD__) # include #elif defined(__OpenBSD__) || defined(__SVR4) # include #elif defined(__APPLE__) # include #elif defined( BSD ) && ( BSD >= 199103 ) # include #elif defined( __QNXNTO__ ) && defined( __LITTLEENDIAN__ ) # define LITTLE_ENDIAN 1234 # define BYTE_ORDER LITTLE_ENDIAN #elif defined( __QNXNTO__ ) && defined( __BIGENDIAN__ ) # define BIG_ENDIAN 1234 # define BYTE_ORDER BIG_ENDIAN #elif defined( _AIX ) # include #else # include #endif /* big endian to cpu */ #if LITTLE_ENDIAN == BYTE_ORDER # define be32_to_cpu(a) bitfn_swap32(a) # define cpu_to_be32(a) bitfn_swap32(a) # define le32_to_cpu(a) (a) # define cpu_to_le32(a) (a) # define be64_to_cpu(a) bitfn_swap64(a) # define cpu_to_be64(a) bitfn_swap64(a) # define le64_to_cpu(a) (a) # define cpu_to_le64(a) (a) # define cpu_to_le32_array(d, s, l) array_copy32(d, s, l) # define le32_to_cpu_array(d, s, l) array_copy32(d, s, l) # define cpu_to_be32_array(d, s, l) array_swap32(d, s, l) # define be32_to_cpu_array(d, s, l) array_swap32(d, s, l) # define cpu_to_le64_array(d, s, l) array_copy64(d, s, l) # define le64_to_cpu_array(d, s, l) array_copy64(d, s, l) # define cpu_to_be64_array(d, s, l) array_swap64(d, s, l) # define be64_to_cpu_array(d, s, l) array_swap64(d, s, l) # define ror32_be(a, s) rol32(a, s) # define rol32_be(a, s) ror32(a, s) # define ARCH_IS_LITTLE_ENDIAN #elif BIG_ENDIAN == BYTE_ORDER # define be32_to_cpu(a) (a) # define cpu_to_be32(a) (a) # define be64_to_cpu(a) (a) # define cpu_to_be64(a) (a) # define le64_to_cpu(a) bitfn_swap64(a) # define cpu_to_le64(a) bitfn_swap64(a) # define le32_to_cpu(a) bitfn_swap32(a) # define cpu_to_le32(a) bitfn_swap32(a) # define cpu_to_le32_array(d, s, l) array_swap32(d, s, l) # define le32_to_cpu_array(d, s, l) array_swap32(d, s, l) # define cpu_to_be32_array(d, s, l) array_copy32(d, s, l) # define be32_to_cpu_array(d, s, l) array_copy32(d, s, l) # define cpu_to_le64_array(d, s, l) array_swap64(d, s, l) # define le64_to_cpu_array(d, s, l) array_swap64(d, s, l) # define cpu_to_be64_array(d, s, l) array_copy64(d, s, l) # define be64_to_cpu_array(d, s, l) array_copy64(d, s, l) # define ror32_be(a, s) ror32(a, s) # define rol32_be(a, s) rol32(a, s) # define ARCH_IS_BIG_ENDIAN #else # error "endian not supported" #endif #endif /* !BITFN_H */ foundation-0.0.23/cbits/foundation_prim.h0000644000000000000000000000020113415353646016605 0ustar0000000000000000#ifndef FOUNDATION_PRIM_H #define FOUNDATION_PRIM_H #include "Rts.h" typedef StgInt FsOffset; typedef StgInt FsCountOf; #endif foundation-0.0.23/cbits/foundation_system.h0000644000000000000000000000320313415353646017167 0ustar0000000000000000#ifndef FOUNDATION_SYSTEM_H # define FOUNDATION_SYSTEM_H #ifdef _WIN32 #define FOUNDATION_SYSTEM_WINDOWS #define FOUNDATION_SYSTEM_API_NO_CLOCK //define something for Windows (32-bit and 64-bit, this part is common) #ifdef _WIN64 #define FOUNDATION_SYSTEM_WINDOWS_64 //define something for Windows (64-bit only) #else #define FOUNDATION_SYSTEM_WINDOWS_32 //define something for Windows (32-bit only) #endif #elif __APPLE__ #include "TargetConditionals.h" #include "Availability.h" #if TARGET_OS_MAC #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_MACOS #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12 #define FOUNDATION_SYSTEM_API_NO_CLOCK #endif // Other kinds of Mac OS #else # error "foundation: system: Unknown Apple platform" #endif #elif __linux__ #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_LINUX // linux #elif defined(__FreeBSD__) #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_BSD #define FOUNDATION_SYSTEM_FREEBSD // freeBSD #elif defined(__NetBSD__) #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_BSD #define FOUNDATION_SYSTEM_NETBSD // NetBSD #elif defined(__OpenBSD__) #define FOUNDATION_SYSTEM_UNIX #define FOUNDATION_SYSTEM_BSD #define FOUNDATION_SYSTEM_OPENBSD // OpenBSD #elif __unix__ // all unices not caught above #define FOUNDATION_SYSTEM_UNIX // Unix #elif defined(_POSIX_VERSION) #define FOUNDATION_SYSTEM_UNIX // POSIX #else # error "foundation: system: Unknown compiler" #endif #endif