foundation 0.0.1 → 0.0.2

raw patch · 97 files changed

+7566/−2227 lines, 97 filesdep +attoparsecdep +bytestringdep +doctestdep ~basedep ~ghc-primPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec, bytestring, doctest, text, vector

Dependency ranges changed: base, ghc-prim

API changes (from Hackage documentation)

Files

• Foundation.hs +37/−21
• Foundation/Array.hs +2/−0
• Foundation/Array/Bitmap.hs +29/−19
• Foundation/Array/Boxed.hs +163/−68
• Foundation/Array/Chunked/Unboxed.hs +367/−0
• Foundation/Array/Unboxed.hs +83/−18
• Foundation/Array/Unboxed/Builder.hs +0/−61
• Foundation/Array/Unboxed/ByteArray.hs +1/−1
• Foundation/Array/Unboxed/Mutable.hs +16/−7
• Foundation/Bits.hs +41/−0
• Foundation/Class/Bifunctor.hs +83/−0
• Foundation/Class/Storable.hs +126/−0
• Foundation/Collection.hs +10/−0
• Foundation/Collection/Buildable.hs +112/−0
• Foundation/Collection/Collection.hs +109/−0
• Foundation/Collection/List.hs +1/−1
• Foundation/Collection/Mutable.hs +13/−8
• Foundation/Collection/Sequential.hs +51/−13
• Foundation/Collection/Zippable.hs +5/−9
• Foundation/Foreign.hs +3/−0
• Foundation/Hashing.hs +21/−0
• Foundation/Hashing/FNV.hs +203/−0
• Foundation/Hashing/Hashable.hs +108/−0
• Foundation/Hashing/Hasher.hs +68/−0
• Foundation/Hashing/SipHash.hs +285/−0
• Foundation/IO/File.hs +1/−1
• Foundation/Internal/Base.hs +22/−0
• Foundation/Internal/CallStack.hs +24/−0
• Foundation/Internal/Environment.hs +34/−0
• Foundation/Internal/MonadTrans.hs +2/−2
• Foundation/Internal/Natural.hs +48/−0
• Foundation/Internal/NumLiteral.hs +117/−0
• Foundation/Internal/Primitive.hs +4/−1
• Foundation/Internal/Types.hs +44/−14
• Foundation/Math/Trigonometry.hs +53/−0
• Foundation/Number.hs +0/−387
• Foundation/Numerical.hs +118/−0
• Foundation/Numerical/Additive.hs +90/−0
• Foundation/Numerical/Floating.hs +30/−0
• Foundation/Numerical/Multiplicative.hs +162/−0
• Foundation/Numerical/Number.hs +58/−0
• Foundation/Numerical/Primitives.hs +30/−0
• Foundation/Numerical/Subtractive.hs +70/−0
• Foundation/Parser.hs +278/−0
• Foundation/Primitive/FinalPtr.hs +1/−1
• Foundation/Primitive/Types.hs +210/−70
• Foundation/Random.hs +123/−0
• Foundation/String.hs +1/−1
• Foundation/String/ASCII.hs +269/−0
• Foundation/String/Encoding/ASCII7.hs +5/−4
• Foundation/String/Encoding/Encoding.hs +3/−3
• Foundation/String/Encoding/ISO_8859_1.hs +6/−5
• Foundation/String/Encoding/UTF16.hs +7/−6
• Foundation/String/Encoding/UTF32.hs +5/−4
• Foundation/String/ModifiedUTF8.hs +14/−17
• Foundation/String/UTF8.hs +284/−112
• Foundation/System/Entropy.hs +43/−0
• Foundation/System/Entropy/Common.hs +20/−0
• Foundation/System/Entropy/Unix.hs +81/−0
• Foundation/System/Entropy/Windows.hs +102/−0
• Foundation/System/Info.hs +1/−0
• Foundation/Tuple.hs +26/−23
• Foundation/Tuple/Nth.hs +97/−0
• Foundation/VFS/FilePath.hs +2/−3
• Foundation/VFS/Path.hs +43/−24
• README.md +74/−5
• benchs/Array.hs +0/−16
• benchs/BenchUtil/Common.hs +25/−0
• benchs/BenchUtil/RefData.hs +44/−0
• benchs/Fake/ByteString.hs +22/−0
• benchs/Fake/Text.hs +22/−0
• benchs/Main.hs +147/−0
• benchs/ProfBreak.hs +0/−9
• benchs/Sys.hs +35/−0
• cbits/foundation_bits.h +253/−0
• cbits/foundation_random.c +144/−0
• cbits/foundation_system.h +52/−0
• foundation.cabal +95/−14
• tests/DocTest.hs +29/−0
• tests/Encoding.hs +0/−956
• tests/ForeignUtils.hs +0/−26
• tests/Imports.hs +69/−0
• tests/Test/Data/ASCII.hs +17/−0
• tests/Test/Data/List.hs +32/−0
• tests/Test/Data/Unicode.hs +45/−0
• tests/Test/Foundation/Array.hs +87/−0
• tests/Test/Foundation/Bits.hs +17/−0
• tests/Test/Foundation/ChunkedUArray.hs +82/−0
• tests/Test/Foundation/Collection.hs +238/−0
• tests/Test/Foundation/Encoding.hs +955/−0
• tests/Test/Foundation/Number.hs +109/−0
• tests/Test/Foundation/Parser.hs +104/−0
• tests/Test/Foundation/Random.hs +112/−0
• tests/Test/Foundation/Storable.hs +127/−0
• tests/Test/Foundation/String.hs +82/−0
• tests/Test/Utils/Foreign.hs +26/−0
• tests/Tests.hs +57/−297

@@ -10,7 +10,6 @@ -- What do they look like? -- -- Alternative Prelude-{-# LANGUAGE CPP #-} module Foundation     ( -- * Standard       -- ** Operators@@ -41,12 +40,17 @@     , Prelude.undefined     , Prelude.seq       -- ** Type classes-    , Prelude.Show (..)+    , Prelude.Show+    , show     , Prelude.Ord (..)     , Prelude.Eq (..)     , Prelude.Bounded (..)     , Prelude.Enum (..)     , Prelude.Functor (..)+    , Integral (..)+    , Fractional (..)+    , HasNegation (..)+    , Foundation.Class.Bifunctor.Bifunctor (..)     , Control.Applicative.Applicative (..)     , Prelude.Monad (..)     , (Control.Monad.=<<)@@ -54,11 +58,14 @@     , IsString(..)     , IsList(..)       -- ** Numeric type classes-    , Foundation.Number.Number (..)-    , Foundation.Number.Signed (..)-    , Foundation.Number.Additive (..)-    , Foundation.Number.Subtractive (..)-    , Foundation.Number.Multiplicative (..)+    , 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 (..)@@ -71,9 +78,11 @@     , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word     , Prelude.Int     , Prelude.Integer+    , Natural     , Prelude.Rational     , Prelude.Float     , Prelude.Double+    , Size(..), Offset(..)       -- ** Collection types     , UArray     , PrimType@@ -87,10 +96,12 @@       -- ** Monoids     , Monoid (..)     , (<>)-      -- ** Folds and traversals-    , Data.Foldable.Foldable-    , Data.Foldable.asum-    , Data.Traversable.Traversable+      -- ** Collection+    , Collection(..)+    , NonEmpty+    , nonEmpty+      -- ** Folds+    , Foldable(..)       -- ** Maybe     , Data.Maybe.mapMaybe     , Data.Maybe.catMaybes@@ -137,24 +148,26 @@ import qualified Control.Exception import qualified Data.Typeable -import qualified Data.Foldable-import qualified Data.Traversable- 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+import           Foundation.Collection (Collection(..), NonEmpty, nonEmpty, Foldable(..)) import qualified Foundation.IO.Terminal  import           GHC.Exts (IsString(..)) import           Foundation.Internal.IsList import qualified Foundation.Internal.Proxy -import qualified Foundation.Number+import qualified Foundation.Numerical import qualified Foundation.Partial import           Foundation.Tuple +import qualified Foundation.Class.Bifunctor+import           Foundation.Internal.Types (Size(..), Offset(..))+import           Foundation.Internal.NumLiteral+import           Foundation.Internal.Natural+ import qualified Data.Maybe import qualified Data.Either import qualified Data.Function@@ -162,16 +175,19 @@  import qualified System.Environment import qualified Data.List-#if MIN_VERSION_base(4,6,0)-import           System.IO.Error-#else-import           System.IO.Error hiding (catch, try)-#endif  import           Data.Monoid ((<>))  -- | Alias to Prelude String ([Char]) for compatibility purpose type LString = Prelude.String++-- | Use the Show class to create a String.+--+-- Note that this is not efficient, since+-- an intermediate [Char] is going to be+-- created before turning into a real String.+show :: Prelude.Show a => a -> String+show = fromList Prelude.. Prelude.show  -- | Returns a list of the program's command line arguments (not including the program name). getArgs :: Prelude.IO [String]

@@ -16,6 +16,7 @@     , MArray     , UArray     , MUArray+    , ChunkedUArray     , Bitmap     , MutableBitmap     , PrimType@@ -28,3 +29,4 @@ import           Foundation.Array.Unboxed import           Foundation.Array.Unboxed.Mutable import           Foundation.Array.Bitmap+import           Foundation.Array.Chunked.Unboxed

@@ -37,8 +37,9 @@ import           Foundation.Internal.Types import           Foundation.Primitive.Monad import qualified Foundation.Collection as C-import           Foundation.Number+import           Foundation.Numerical import           Data.Bits+import           Foundation.Bits import           GHC.ST import qualified Data.List @@ -49,6 +50,12 @@ 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@@ -76,8 +83,13 @@     foldl' = foldl'     foldr' = foldr' -instance C.Sequential Bitmap where+instance C.Collection Bitmap where     null = null+    length = length+    elem e = Data.List.elem e . toList+    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO can shortcircuit all this massively+    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO DITTO+instance C.Sequential Bitmap where     take = take     drop = drop     splitAt = splitAt@@ -95,7 +107,6 @@     intersperse = intersperse     find = find     sortBy = sortBy-    length = length     singleton = fromList . (:[])  instance C.IndexedCollection Bitmap where@@ -111,7 +122,7 @@             | otherwise                   = Nothing  instance C.MutableCollection MutableBitmap where-    type Collection MutableBitmap = Bitmap+    type MutableFreezed MutableBitmap = Bitmap     type MutableKey MutableBitmap = Int     type MutableValue MutableBitmap = Bool @@ -120,13 +131,14 @@     unsafeThaw = unsafeThaw     unsafeFreeze = unsafeFreeze +    mutNew n = new (Size n)     mutUnsafeWrite = unsafeWrite     mutUnsafeRead = unsafeRead     mutWrite = write     mutRead = read -bitmapIndex :: Int -> (Int, Int)-bitmapIndex !i = i `divMod` bitsPerTy+bitmapIndex :: Offset Bool -> (Int, Int)+bitmapIndex (Offset !i) = (i .>>. shiftPerTy, i .&. maskPerTy) {-# INLINE bitmapIndex #-}  -- return the index in word32 quantity and mask to a bit in a bitmap@@ -183,7 +195,7 @@  unsafeWrite :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> Bool -> prim () unsafeWrite (MutableBitmap _ ma) i v = do-    let (idx, bitIdx) = bitmapIndex i+    let (idx, bitIdx) = bitmapIndex (Offset i)     w <- A.unsafeRead ma idx     let w' = if v then setBit w bitIdx else clearBit w bitIdx     A.unsafeWrite ma idx w'@@ -191,7 +203,7 @@  unsafeRead :: PrimMonad prim => MutableBitmap (PrimState prim) -> Int -> prim Bool unsafeRead (MutableBitmap _ ma) i = do-    let (idx, bitIdx) = bitmapIndex i+    let (idx, bitIdx) = bitmapIndex (Offset i)     flip testBit bitIdx `fmap` A.unsafeRead ma idx {-# INLINE unsafeRead #-} @@ -226,7 +238,7 @@ -- use 'index' if unsure. unsafeIndex :: Bitmap -> Int -> Bool unsafeIndex (Bitmap _ ba) n =-    let (idx, bitIdx) = bitmapIndex n+    let (idx, bitIdx) = bitmapIndex (Offset n)      in testBit (A.unsafeIndex ba idx) bitIdx  {-# INLINE unsafeIndex #-}@@ -243,11 +255,17 @@ empty :: Bitmap empty = Bitmap 0 A.empty +new :: PrimMonad prim => Size Bool -> prim (MutableBitmap (PrimState prim))+new (Size len) =+    MutableBitmap len <$> A.new nbElements+  where+    nbElements :: Size Word32+    nbElements = Size ((len `alignRoundUp` bitsPerTy) .>>. shiftPerTy)+ -- | make an array from a list of elements. vFromList :: [Bool] -> Bitmap vFromList allBools = runST $ do-    mba <- A.new nbElements-    let mbitmap = MutableBitmap len mba+    mbitmap <- new (Size len)     loop mbitmap 0 allBools   where     loop mb _ []     = unsafeFreeze mb@@ -271,14 +289,6 @@         C.foldl (.|.) 0 $ Prelude.zipWith (\b w -> if b then (1 `shiftL` w) else 0) l (C.reverse [0..31]) -} -    nbElements :: Size Word32-    nbElements = Size (len `divUp` bitsPerTy)--    divUp a b-        | d == 0    = c-        | otherwise = c+1-      where-        (c,d) = a `divMod` b      len        = C.length allBools 

@@ -13,26 +13,52 @@ module Foundation.Array.Boxed     ( Array     , MArray+    , empty+    , copy+    , copyAt+    , unsafeCopyAtRO+    , thaw+    , new+    , unsafeFreeze+    , unsafeThaw+    , freeze+    , unsafeWrite+    , unsafeIndex     ) where  import           GHC.Prim import           GHC.Types import           GHC.ST-import           Foundation.Number+import           Foundation.Numerical import           Foundation.Internal.Base+import           Foundation.Internal.MonadTrans import           Foundation.Internal.Types import           Foundation.Primitive.Types import           Foundation.Primitive.Monad import           Foundation.Array.Common import qualified Foundation.Collection as C+import qualified Foundation.Collection.Buildable as CB import qualified Prelude+import qualified Data.List  -- | Array of a-data Array a = Array (Array# a)+data Array a = Array {-# UNPACK #-} !(Offset a)+                     {-# UNPACK #-} !(Size a)+                                    (Array# a)     deriving (Typeable) +instance Data ty => Data (Array ty) where+    dataTypeOf _ = arrayType+    toConstr _   = error "toConstr"+    gunfold _ _  = error "gunfold"++arrayType :: DataType+arrayType = mkNoRepType "Foundation.Array"+ -- | Mutable Array of a-data MArray a st = MArray (MutableArray# st a)+data MArray a st = MArray {-# UNPACK #-} !(Offset a)+                          {-# UNPACK #-} !(Size a)+                                         (MutableArray# st a)     deriving (Typeable)  instance Functor Array where@@ -60,8 +86,18 @@  instance C.InnerFunctor (Array ty) -instance C.Sequential (Array ty) where+instance C.Foldable (Array ty) where+    foldl = aFoldl+    foldr = aFoldr+    foldl' = aFoldl'++instance C.Collection (Array ty) where     null = null+    length = length+    elem e = Data.List.elem e . toList+    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO+    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO+instance C.Sequential (Array ty) where     take = take     drop = drop     splitAt = splitAt@@ -80,11 +116,10 @@     cons = cons     find = find     sortBy = sortBy-    length = length     singleton = fromList . (:[])  instance C.MutableCollection (MArray ty) where-    type Collection (MArray ty) = Array ty+    type MutableFreezed (MArray ty) = Array ty     type MutableKey (MArray ty) = Int     type MutableValue (MArray ty) = ty @@ -93,6 +128,7 @@     unsafeThaw = unsafeThaw     unsafeFreeze = unsafeFreeze +    mutNew n = new (Size n)     mutUnsafeWrite = unsafeWrite     mutUnsafeRead = unsafeRead     mutWrite = write@@ -111,24 +147,56 @@                 if predicate (unsafeIndex c i) then Just i else Nothing  instance C.Zippable (Array ty) where-    -- TODO Use an array builder once available-    zipWith f a b = runST $ do-        mv <- new len-        go mv 0 f (toList a) (toList b)-        unsafeFreeze mv-      where-        !len = Size $ min (C.length a) (C.length b)-        go _  _  _ []       _        = return ()-        go _  _  _ _        []       = return ()-        go mv i f' (a':as') (b':bs') = do-            write mv i (f' a' b')-            go mv (i + 1) f' as' bs'+  zipWith f as bs = runST $ CB.build 64 $ go f (toList as) (toList bs)+    where+      go _  []       _        = return ()+      go _  _        []       = return ()+      go f' (a':as') (b':bs') = CB.append (f' a' b') >> go f' as' bs'  instance C.BoxedZippable (Array ty) +instance CB.Buildable (Array ty) where+  type Mutable (Array ty) = MArray ty+  type Step (Array ty) = ty++  append v = CB.Builder $ State $ \(i, st) ->+      if offsetAsSize i == CB.chunkSize st+          then do+              cur      <- unsafeFreeze (CB.curChunk st)+              newChunk <- new (CB.chunkSize st)+              unsafeWrite newChunk 0 v+              return ((), (Offset 1, st { CB.prevChunks     = cur : CB.prevChunks st+                                        , CB.prevChunksSize = CB.chunkSize st + CB.prevChunksSize st+                                        , CB.curChunk       = newChunk+                                        }))+          else do+              let (Offset i') = i+              unsafeWrite (CB.curChunk st) i' v+              return ((), (i + Offset 1, st))+  {-# INLINE append #-}++  build sizeChunksI ab+    | sizeChunksI <= 0 = CB.build 64 ab+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st)) <- runState (CB.runBuilder ab) (Offset 0, CB.BuildingState [] (Size 0) first sizeChunks)+        cur           <- unsafeFreezeShrink (CB.curChunk st) (offsetAsSize i)+        -- Build final array+        let totalSize = CB.prevChunksSize st + offsetAsSize i+        new totalSize >>= fillFromEnd totalSize (cur : CB.prevChunks st) >>= unsafeFreeze+    where+      sizeChunks = Size sizeChunksI++      fillFromEnd _   []     mua = return mua+      fillFromEnd !end (x:xs) mua = do+          let sz = lengthSize x+          unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz+          fillFromEnd (end - sz) xs mua+  {-# INLINE build #-}+ -- | return the numbers of elements in a mutable array mutableLength :: MArray ty st -> Int-mutableLength (MArray ma) = I# (sizeofMutableArray# ma)+mutableLength (MArray _ (Size len) _) = len {-# INLINE mutableLength #-}  -- | Return the element at a specific index from an array.@@ -146,7 +214,7 @@ -- Reading from invalid memory can return unpredictable and invalid values. -- use 'index' if unsure. unsafeIndex :: Array ty -> Int -> ty-unsafeIndex (Array a) (I# n) = let (# v #) = indexArray# a n in v+unsafeIndex (Array start _ a) ofs = primArrayIndex a (start+Offset ofs) {-# INLINE unsafeIndex #-}  -- | read a cell in a mutable array.@@ -164,8 +232,7 @@ -- Reading from invalid memory can return unpredictable and invalid values. -- use 'read' if unsure. unsafeRead :: PrimMonad prim => MArray ty (PrimState prim) -> Int -> prim ty-unsafeRead (MArray ma) (I# i) = primitive $ \s1 -> readArray# ma i s1---readArray# :: MutableArray# s a -> Int# -> State# s -> (#State# s, a#)+unsafeRead (MArray start _ ma) i = primMutableArrayRead ma (start + Offset i) {-# INLINE unsafeRead #-}  -- | Write to a cell in a mutable array.@@ -183,23 +250,24 @@ -- Writing with invalid bounds will corrupt memory and your program will -- become unreliable. use 'write' if unsure. unsafeWrite :: PrimMonad prim => MArray ty (PrimState prim) -> Int -> ty -> prim ()-unsafeWrite (MArray ma) (I# i) v = primitive $ \s1 -> let !s2 = writeArray# ma i v s1 in (# s2, () #)+unsafeWrite (MArray start _ ma) ofs v =+    primMutableArrayWrite ma (start + Offset ofs) v {-# INLINE unsafeWrite #-}  -- | Freeze a mutable array into an array. -- -- the MArray must not be changed after freezing. unsafeFreeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty)-unsafeFreeze (MArray ma) = primitive $ \s1 ->+unsafeFreeze (MArray ofs sz ma) = primitive $ \s1 ->     case unsafeFreezeArray# ma s1 of-        (# s2, a #) -> (# s2, Array a #)+        (# s2, a #) -> (# s2, Array ofs sz a #) {-# INLINE unsafeFreeze #-}  -- | Thaw an immutable array. -- -- The Array must not be used after thawing. unsafeThaw :: PrimMonad prim => Array ty -> prim (MArray ty (PrimState prim))-unsafeThaw (Array a) = primitive $ \st -> (# st, MArray (unsafeCoerce# a) #)+unsafeThaw (Array ofs sz a) = primitive $ \st -> (# st, MArray ofs sz (unsafeCoerce# a) #) {-# INLINE unsafeThaw #-}  -- | Thaw an array to a mutable array.@@ -221,6 +289,10 @@   where     sz = Size $ mutableLength marray +-- | Copy the element to a new element array+copy :: Array ty -> Array ty+copy a = runST (unsafeThaw a >>= freeze)+ -- | Copy a number of elements from an array to another array with offsets copyAt :: PrimMonad prim        => MArray ty (PrimState prim) -- ^ destination array@@ -247,11 +319,11 @@                -> Offset ty                  -- ^ offset at source                -> Size ty                    -- ^ number of elements to copy                -> prim ()-unsafeCopyAtRO dst od src os n = loop od os-  where !endIndex = os `offsetPlusE` n-        loop (Offset d) s@(Offset i)-            | s == endIndex = return ()-            | otherwise     = unsafeWrite dst d (unsafeIndex src i) >> loop (Offset $ d+1) (Offset $ i+1)+unsafeCopyAtRO (MArray (Offset (I# dstart)) _ da) (Offset (I# dofs))+               (Array  (Offset (I# sstart)) _ sa) (Offset (I# sofs))+               (Size (I# n)) =+    primitive $ \st ->+        (# copyArray# sa (sstart +# sofs) da (dstart +# dofs) n st, () #)  -- | Allocate a new array with a fill function that has access to the elements of --   the source array.@@ -275,9 +347,9 @@ -- All mutable arrays are allocated on a 64 bits aligned addresses -- and always contains a number of bytes multiples of 64 bits. new :: PrimMonad prim => Size ty -> prim (MArray ty (PrimState prim))-new (Size (I# n)) = primitive $ \s1 ->+new sz@(Size (I# n)) = primitive $ \s1 ->     case newArray# n (error "vector: internal error uninitialized vector") s1 of-        (# s2, ma #) -> (# s2, MArray ma #)+        (# s2, ma #) -> (# s2, MArray (Offset 0) sz ma #)  -- | Create a new array of size @n by settings each cells through the -- function @f.@@ -325,10 +397,10 @@ empty = runST $ onNewArray 0 (\_ s -> s)  length :: Array a -> Int-length (Array a) = I# (sizeofArray# a)+length (Array _ (Size len) _) = len  lengthSize :: Array a -> Size a-lengthSize (Array a) = Size $ I# (sizeofArray# a)+lengthSize (Array _ sz _) = sz  vFromList :: [a] -> Array a vFromList l = runST (new len >>= loop 0 l)@@ -385,11 +457,11 @@            => Int            -> (MutableArray# (PrimState m) a -> State# (PrimState m) -> State# (PrimState m))            -> m (Array a)-onNewArray (I# len) f = primitive $ \st -> do-    case newArray# len (error "onArray") st of { (# st2, mv #) ->-    case f mv st2                           of { st3           ->-    case unsafeFreezeArray# mv st3          of { (# st4, a #)  ->-        (# st4, Array a #) }}}+onNewArray len@(I# len#) f = primitive $ \st -> do+    case newArray# len# (error "onArray") st of { (# st2, mv #) ->+    case f mv st2                            of { st3           ->+    case unsafeFreezeArray# mv st3           of { (# st4, a #)  ->+        (# st4, Array (Offset 0) (Size len) a #) }}}  ----------------------------------------------------------------------- @@ -398,28 +470,29 @@ null = (==) 0 . length  take ::  Int -> Array ty -> Array ty-take nbElems v+take nbElems a@(Array start len arr)     | nbElems <= 0 = empty-    | otherwise    = runST $ do-        muv <- new n-        unsafeCopyAtRO muv (Offset 0) v (Offset 0) n-        unsafeFreeze muv+    | n == len     = a+    | otherwise    = Array start n arr   where-    n = Size $ min nbElems (length v)+    n = min (Size nbElems) len  drop ::  Int -> Array ty -> Array ty-drop nbElems v-    | nbElems <= 0 = v-    | otherwise    = runST $ do-        muv <- new n-        unsafeCopyAtRO muv (Offset 0) v (Offset offset) n-        unsafeFreeze muv+drop nbElems a@(Array start len arr)+    | nbElems <= 0 = a+    | n == len     = empty+    | otherwise    = Array (start `offsetPlusE` n) (len - n) arr   where-    offset = min nbElems (length v)-    n = Size (length v - offset)+    n = min (Size nbElems) len  splitAt ::  Int -> Array ty -> (Array ty, Array ty)-splitAt n v = (take n v, drop n v)+splitAt nbElems a@(Array start len arr)+    | nbElems <= 0 = (empty, a)+    | n == len     = (a, empty)+    | otherwise    =+        (Array start n arr, Array (start `offsetPlusE` n) (len - n) arr)+  where+    n = min (Size nbElems) len  revTake :: Int -> Array ty -> Array ty revTake nbElems v = drop (length v - nbElems) v@@ -439,26 +512,21 @@     !len = lengthSize vec     !endIdx = Offset 0 `offsetPlusE` len     loop prevIdx idx@(Offset i)-        | idx == endIdx = [runST $ sub vec prevIdx idx]+        | idx == endIdx = [sub vec prevIdx idx]         | otherwise     =             let e = unsafeIndex vec i                 idx' = idx + Offset 1              in if predicate e-                    then runST (sub vec prevIdx idx) : loop idx' idx'+                    then sub vec prevIdx idx : loop idx' idx'                     else loop prevIdx idx' -sub :: PrimMonad prim => Array ty -> Offset ty -> Offset ty -> prim (Array ty)-sub vec startIdx expectedEndIdx-    | startIdx == endIdx           = return empty-    | startIdx >= sizeAsOffset len = return empty-    | otherwise                    = new sz >>= loop startIdx (Offset 0)+sub :: Array ty -> Offset ty -> Offset ty -> Array ty+sub (Array start len a) startIdx expectedEndIdx+    | startIdx == endIdx           = empty+    | otherwise                    = Array (start + startIdx) newLen a   where-    !len = lengthSize vec-    loop os@(Offset s) od@(Offset d) mv-        | os == endIdx = unsafeFreeze mv-        | otherwise    = unsafeWrite mv d (unsafeIndex vec s) >> loop (os+Offset 1) (od+Offset 1) mv-    !sz  = endIdx - startIdx-    !endIdx = min expectedEndIdx (sizeAsOffset $ lengthSize vec)+    newLen = endIdx - startIdx+    endIdx = min expectedEndIdx (sizeAsOffset len)  break ::  (ty -> Bool) -> Array ty -> (Array ty, Array ty) break predicate v = findBreak 0@@ -600,8 +668,35 @@     copyAt m (Offset 0) mvec (Offset 0) (offsetAsSize d)     unsafeFreeze m +unsafeFreezeShrink :: PrimMonad prim => MArray ty (PrimState prim) -> Size ty -> prim (Array ty)+unsafeFreezeShrink (MArray start _ ma) n = unsafeFreeze (MArray start n ma)+ reverse :: Array ty -> Array ty reverse a = create len toEnd   where     len = length a     toEnd i = unsafeIndex a (len - i - 1)++aFoldl :: (a -> ty -> a) -> a -> Array ty -> a+aFoldl 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))++aFoldr :: (ty -> a -> a) -> a -> Array ty -> a+aFoldr f initialAcc vec = loop 0+  where+    len = length vec+    loop !i+        | i == len  = initialAcc+        | otherwise = unsafeIndex vec i `f` loop (i+1)++aFoldl' :: (a -> ty -> a) -> a -> Array ty -> a+aFoldl' 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))

@@ -0,0 +1,367 @@+-- |+-- Module      : Foundation.Array.Chunked.Unboxed+-- License     : BSD-style+-- Maintainer  : Alfredo Di Napoli <alfredo.dinapoli@gmail.com>+-- Stability   : experimental+-- Portability : portable+--+-- Simple array-of-arrays abstraction+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Foundation.Array.Chunked.Unboxed+    ( ChunkedUArray+    ) where++import qualified Data.List+import           Data.Typeable+import           Foundation.Array.Boxed (Array)+import qualified Foundation.Array.Boxed as A+import           Foundation.Array.Common+import           Foundation.Array.Unboxed (UArray)+import qualified Foundation.Array.Unboxed as U+import           Foundation.Class.Bifunctor+import qualified Foundation.Collection as C+import           Foundation.Internal.Base+import           Foundation.Internal.Types+import           Foundation.Numerical+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Types+import           GHC.ST+import qualified Prelude as P+++data ChunkedUArray ty = ChunkedUArray (Array (UArray ty))+                      deriving (Show, Ord, Typeable)++instance PrimType ty => Eq (ChunkedUArray ty) where+  (==) = equal++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.Collection (ChunkedUArray ty) where+    null = null+    length = length+    elem   = elem+    minimum = minimum+    maximum = maximum++instance PrimType ty => C.Sequential (ChunkedUArray ty) where+    take = take+    drop = drop+    revTake = revTake+    revDrop = revDrop+    splitOn = splitOn+    break = break+    intersperse = intersperse+    filter = filter+    reverse = reverse+    unsnoc = unsnoc+    uncons = uncons+    snoc = snoc+    cons = cons+    find = find+    sortBy = sortBy+    singleton = fromList . (:[])++instance PrimType ty => C.IndexedCollection (ChunkedUArray ty) where+    (!) l n+        | n < 0 || 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 $ runST $ do+  let a1Size@(Size a1len) = Size $ C.length a1+  let a2Size              = Size $ C.length a2+  a <- A.new (a1Size + a2Size)+  A.thaw a1 >>= \a1' -> A.copyAt a (Offset 0) a1' (Offset 0) a1Size+  A.thaw a2 >>= \a2' -> A.copyAt a (Offset a1len) a2' (Offset 0) a2Size+  A.unsafeFreeze a++concat :: [ChunkedUArray ty] -> ChunkedUArray ty+concat x = C.foldl' append mempty x++vFromList :: PrimType ty => [ty] -> ChunkedUArray ty+vFromList l = ChunkedUArray array+  where+    array = runST $ do+      a <- A.new (Size 1)+      A.unsafeWrite a 0 (fromList l)+      A.unsafeFreeze a++vToList :: PrimType ty => ChunkedUArray ty -> [ty]+vToList (ChunkedUArray a) = loop (C.length a) 0 mempty+  where+    -- TODO: Rewrite this to use something like a `DList`+    -- to avoid the expensive `mappend`.+    loop len !acc l = case acc >= len of+      True  -> l+      False -> loop len (acc+1) ((toList (A.unsafeIndex a acc)) <> l)++null :: PrimType ty => ChunkedUArray ty -> Bool+null (ChunkedUArray array) =+  let len = C.length array+  in C.null array || allNulls 0 len+  where+    allNulls !idx len+      | idx == len = True+      | otherwise  = C.null (array `A.unsafeIndex` idx) && allNulls (idx + 1) len++-- | 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 -> Int+length (ChunkedUArray array) = C.foldl' (\acc l -> acc + C.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 array = go 0+  where+    len = C.length array+    go !currentIndex = case currentIndex < len of+      True  -> case el == array `unsafeIndex` currentIndex of+        True  -> True+        False -> go (currentIndex + 1)+      False -> False++-- | TODO: Improve implementation.+minimum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty+minimum = Data.List.minimum . toList . C.getNonEmpty++-- | TODO: Improve implementation.+maximum :: (Ord ty, PrimType ty) => C.NonEmpty (ChunkedUArray ty) -> ty+maximum = Data.List.maximum . toList . C.getNonEmpty++-- | 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 && deepEqual+  where+    len1 = C.length ca1+    len2 = C.length ca2++    deepEqual :: Bool+    deepEqual = go 0 0++    go !x !y+      | x == len1 && y == len2 = True+      | otherwise =+        (ca1 `unsafeIndex` x == ca2 `unsafeIndex` y) && go (x + 1) (y + 1)++-- | Take the first n elements from this `ChunkedUArray`.+-- TODO: Perform compaction? Compacting the underlying chunks will have+-- the snag of copying data, but the pro of improving cache-friendliness+-- and reduce data scattering.+take :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+take nbElems v@(ChunkedUArray inner)+    | nbElems <= 0 = empty+    | C.null v     = empty+    | nbElems >= C.length v = v+    | otherwise =+      let newSize = Size requiredChunks+      in ChunkedUArray $ runST (A.new newSize >>= iter inner nbElems)+  where+    -- TODO: How can we avoid this first pass?+    requiredChunks = loop 0 nbElems+      where+        loop !idx !remaining+          | remaining <= 0 = idx+          | otherwise =+            let vec = inner `A.unsafeIndex` idx+                l = U.length vec+            in loop (idx + 1) (remaining - l)+    iter :: (PrimType ty, PrimMonad prim)+         => Array (UArray ty)+         -> Int+         -> A.MArray (UArray ty) (PrimState prim)+         -> prim (Array (UArray ty))+    iter inner0 elems finalVector = loop 0 elems+      where+        loop !currentIndex !remainingElems+          | remainingElems <= 0 || currentIndex >= C.length inner0 = A.unsafeFreeze finalVector+          | otherwise =+            let chunk = inner0 `A.unsafeIndex` currentIndex -- TODO: skip empty chunks+                chunkLen = C.length chunk+            in case C.null chunk of+              True -> loop (currentIndex + 1) remainingElems+              False -> case chunkLen <= remainingElems of+                True -> do+                  A.unsafeWrite finalVector currentIndex chunk+                  loop (currentIndex + 1) (remainingElems - chunkLen)+                False -> do+                  nc <- do+                    newChunk <- U.new (Size remainingElems)+                    U.unsafeCopyAtRO newChunk (Offset 0) chunk (Offset 0) (Size remainingElems)+                    U.unsafeFreeze newChunk+                  A.unsafeWrite finalVector currentIndex nc+                  A.freeze finalVector++drop :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+drop nbElems v@(ChunkedUArray inner)+    | nbElems >= C.length v = empty+    | nbElems <= 0 = v+    | C.null v     = empty+    | otherwise =+      let newSize = Size (C.length inner - chunksToSkip)+      in ChunkedUArray $ runST (A.new newSize >>= iter inner nbElems)+  where+    -- TODO: How can we avoid this first pass?+    chunksToSkip = loop 0 nbElems+      where+        loop !idx !remaining =+          let vec   = inner `A.unsafeIndex` idx+              l     = U.length vec+              slack = remaining - l+          in case slack of+            x | x == 0 -> idx + 1+            x | x <  0 -> idx+            _          -> loop (idx + 1) slack+    iter :: (PrimType ty, PrimMonad prim)+         => Array (UArray ty)+         -> Int+         -> A.MArray (UArray ty) (PrimState prim)+         -> prim (Array (UArray ty))+    iter inner0 elems finalVector = loop 0 elems+      where+        -- We do not skip empty chunks, or this would screw+        -- the total, final size.+        loop !currentIndex !remainingElems+          | remainingElems <= 0 = do+            -- Copy the rest of the vector+            A.unsafeCopyAtRO finalVector (Offset 0) inner0 (Offset currentIndex) (Size $ C.length inner0 - currentIndex)+            A.freeze finalVector+          | otherwise =+            let chunk = inner0 `A.unsafeIndex` currentIndex+                chunkLen = C.length chunk+                slack    = chunkLen P.- remainingElems+            in case chunkLen <= remainingElems of+                True -> do+                  -- Skip the whole chunk+                  loop (currentIndex + 1) (remainingElems - chunkLen)+                False -> do+                  nc <- do+                    newChunk <- U.new (Size slack)+                    U.unsafeCopyAtRO newChunk (Offset 0) chunk (Offset remainingElems) (Size slack)+                    U.unsafeFreeze newChunk+                  A.unsafeWrite finalVector 0 nc+                  -- Copy the rest of the vector+                  let !nextIdx = currentIndex + 1+                  A.unsafeCopyAtRO finalVector (Offset 1) inner0 (Offset nextIdx) (Size $ C.length inner0 - nextIdx)+                  A.freeze finalVector+++-- TODO: Improve implementation.+revTake :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+revTake x = fromList . C.revTake x . toList++-- TODO: Improve implementation.+revDrop :: PrimType ty => Int -> ChunkedUArray ty -> ChunkedUArray ty+revDrop x = fromList . C.revDrop x . toList++-- 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.+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)++snoc :: PrimType ty => ChunkedUArray ty -> ty -> ChunkedUArray ty+snoc (ChunkedUArray inner) el = ChunkedUArray $ runST $ do+  let newLen = (Size $ 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) (Size $ C.length inner)+  A.unsafeFreeze newArray++cons :: PrimType ty => ty -> ChunkedUArray ty -> ChunkedUArray ty+cons el (ChunkedUArray inner) = ChunkedUArray $ runST $ do+  newArray   <- A.new (Size $ C.length inner + 1)+  let single = fromList [el]+  A.unsafeCopyAtRO newArray (Offset 0) inner (Offset 0) (Size $ C.length inner)+  A.unsafeWrite newArray (C.length inner) single+  A.unsafeFreeze newArray++find :: PrimType ty => (ty -> Bool) -> ChunkedUArray ty -> Maybe ty+find fn v = loop 0 (C.length v)+  where+    loop !idx len+      | idx >= len = Nothing+      | otherwise  =+        let currentElem = v `unsafeIndex` idx+        in case fn currentElem of+          True  -> Just currentElem+          False -> loop (idx + 1) len++-- 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 -> Int -> ty+index array n+    | n < 0 || n >= len = throw (OutOfBound OOB_Index n len)+    | otherwise         = unsafeIndex array n+  where len = C.length array+{-# INLINE index #-}++unsafeIndex :: PrimType ty => ChunkedUArray ty -> Int -> 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 i - (C.length u) of+        i' | i' >= 0 -> go (A.unsafeIndex array (globalIndex + 1)) (globalIndex + 1) i'+        _            -> U.unsafeIndex u i+{-# INLINE unsafeIndex #-}

@@ -45,6 +45,7 @@     , unsafeUpdate     , unsafeIndex     , unsafeIndexer+    , unsafeDewrap     , unsafeRead     , unsafeWrite     -- * Functions@@ -63,6 +64,7 @@     , splitElem     , break     , breakElem+    , elem     , intersperse     , span     , cons@@ -97,7 +99,7 @@ import           Foundation.Primitive.Utils import           Foundation.Array.Common import           Foundation.Array.Unboxed.Mutable-import           Foundation.Number+import           Foundation.Numerical import qualified Data.List  -- | An array of type built on top of GHC primitive.@@ -113,7 +115,16 @@     | UVecAddr {-# UNPACK #-} !(Offset ty)                {-# UNPACK #-} !(Size ty)                               !(FinalPtr ty)+    deriving (Typeable) +instance Data ty => Data (UArray ty) where+    dataTypeOf _ = arrayType+    toConstr _   = error "toConstr"+    gunfold _ _  = error "gunfold"++arrayType :: DataType+arrayType = mkNoRepType "Foundation.UArray"+ instance (PrimType ty, Show ty) => Show (UArray ty) where     show v = show (toList v) instance (PrimType ty, Eq ty) => Eq (UArray ty) where@@ -180,7 +191,14 @@     {-# INLINE primAddrIndex' #-} {-# NOINLINE unsafeIndexer #-} -{-# SPECIALIZE [3] unsafeIndexer :: UArray Word8 -> ((Offset Word8 -> Word8) -> ST s a) -> ST s a #-}+unsafeDewrap :: PrimType ty+             => (ByteArray# -> Offset ty -> a)+             -> (Ptr ty -> Offset ty -> ST s a)+             -> UArray ty+             -> a+unsafeDewrap _ g (UVecAddr start _ fptr) = withUnsafeFinalPtr fptr $ \ptr -> g ptr start+unsafeDewrap f _ (UVecBA start _ _ ba)   = f ba start+{-# INLINE unsafeDewrap #-}  foreignMem :: PrimType ty            => FinalPtr ty -- ^ the start pointer with a finalizer@@ -267,6 +285,7 @@ unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Size ty -> prim (UArray ty) unsafeFreezeShrink (MUVecMA start _ pinnedState mba) n = unsafeFreeze (MUVecMA start n pinnedState mba) unsafeFreezeShrink (MUVecAddr start _ fptr) n = unsafeFreeze (MUVecAddr start n fptr)+{-# INLINE unsafeFreezeShrink #-}  freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty) freeze ma = do@@ -461,10 +480,10 @@                 {-# INLINE loop #-}         {-# INLINE doUpdate #-} -withPtr :: PrimType ty+withPtr :: (PrimMonad prim, PrimType ty)         => UArray ty-        -> (Ptr ty -> IO a)-        -> IO a+        -> (Ptr ty -> prim a)+        -> prim a withPtr vec@(UVecAddr start _ fptr)  f =     withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))   where@@ -485,10 +504,10 @@     sz           = primSizeInBytes (vectorProxyTy vec)     !(Offset os) = offsetOfE sz start -withMutablePtr :: PrimType ty-               => MUArray ty RealWorld-               -> (Ptr ty -> IO a)-               -> IO a+withMutablePtr :: (PrimMonad prim, PrimType ty)+               => MUArray ty (PrimState prim)+               -> (Ptr ty -> prim a)+               -> prim a withMutablePtr muvec f = do     v <- unsafeFreeze muvec     withPtr v f@@ -521,25 +540,25 @@ take :: PrimType ty => Int -> UArray ty -> UArray ty take nbElems v     | nbElems <= 0 = empty-    | n == vlen    = v+    | n >= vlen    = v     | otherwise    =         case v of             UVecBA start _ pinst ba -> UVecBA start n pinst ba             UVecAddr start _ fptr   -> UVecAddr start n fptr   where-    n = min (Size nbElems) vlen+    n    = Size nbElems     vlen = lengthSize v  drop :: PrimType ty => Int -> UArray ty -> UArray ty drop nbElems v     | nbElems <= 0 = v-    | n == vlen    = empty+    | n >= vlen    = empty     | otherwise    =         case v of             UVecBA start len pinst ba -> UVecBA (start `offsetPlusE` n) (len - n) pinst ba             UVecAddr start len fptr   -> UVecAddr (start `offsetPlusE` n) (len - n) fptr   where-    n = min (Size nbElems) vlen+    n    = Size nbElems     vlen = lengthSize v  splitAt :: PrimType ty => Int -> UArray ty -> (UArray ty, UArray ty)@@ -569,8 +588,8 @@     !k = loop start     loop !i | i < end && t /= ty = loop (i+Offset 1)             | otherwise          = i-        where !t                 = primBaIndex ba i-splitElem ty r@(UVecAddr start len fptr)+        where t                  = primBaIndex ba i+splitElem !ty r@(UVecAddr start len fptr)     | k == end  = (# r, empty #)     | otherwise =         (# UVecAddr start (offsetAsSize k) fptr@@ -658,15 +677,39 @@ {-# NOINLINE [2] break #-} {-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} +{- {-# RULES "break (== ty)" [3] forall (x :: forall ty . PrimType ty => ty) . break (== x) = breakElem x #-} {-# RULES "break (ty ==)" [3] forall (x :: forall ty . PrimType ty => ty) . break (x ==) = breakElem x #-} {-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-}+-}  breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) breakElem xelem xv = let (# v1, v2 #) = splitElem xelem xv in (v1, v2) {-# SPECIALIZE [2] breakElem :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8) #-} {-# SPECIALIZE [2] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-} +elem :: PrimType ty => ty -> UArray ty -> Bool+elem !ty (UVecBA start len _ ba)+    | k == end   = False+    | otherwise  = True+  where+    !end = start `offsetPlusE` len+    !k = loop start+    loop !i | i < end && t /= ty = loop (i+Offset 1)+            | otherwise          = i+        where t                  = primBaIndex ba i+elem ty (UVecAddr start len fptr)+    | k == end  = False+    | otherwise = True+  where+    !(Ptr addr) = withFinalPtrNoTouch fptr id+    !end = start `offsetPlusE` len+    !k = loop start+    loop !i | i < end && t /= ty = loop (i+Offset 1)+            | otherwise          = i+        where t                  = primAddrIndex addr i+{-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-}+ intersperse :: PrimType ty => ty -> UArray ty -> UArray ty intersperse sep v     | len <= 1  = v@@ -777,10 +820,32 @@ filter predicate vec = vFromList $ Data.List.filter predicate $ vToList vec  reverse :: PrimType ty => UArray ty -> UArray ty-reverse a = create len toEnd+reverse a+    | len == Size 0 = empty+    | otherwise     = runST $ do+        ma <- newNative len $ \mba ->+                case a of+                    (UVecBA start _ _ ba)   -> goNative endOfs mba ba start+                    (UVecAddr start _ fptr) -> withFinalPtr fptr $ \ptr -> goAddr endOfs mba ptr start+        unsafeFreeze ma   where-    len = length a-    toEnd i = unsafeIndex a (len - i - 1)+    !len = lengthSize a+    !endOfs = Offset 0 `offsetPlusE` len++    goNative :: PrimType ty => Offset ty -> MutableByteArray# s -> ByteArray# -> Offset ty -> ST s ()+    goNative !end !ma !ba !srcStart = loop (Offset 0)+      where+        !endI = sizeAsOffset ((srcStart + end) - Offset 1)+        loop !i+            | i == end  = return ()+            | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+Offset 1)+    goAddr !end !ma !(Ptr ba) !srcStart = loop (Offset 0)+      where+        !endI = sizeAsOffset ((srcStart + end) - Offset 1)+        loop !i+            | i == end  = return ()+            | otherwise = primMbaWrite ma i (primAddrIndex ba (sizeAsOffset (endI - i))) >> loop (i+Offset 1)+{-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-}  foldl :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a foldl f initialAcc vec = loop 0 initialAcc

@@ -1,61 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Foundation.Array.Unboxed.Builder-    ( ArrayBuilder-    , appendTy-    , build-    ) where--import           Foundation.Array.Unboxed-import           Foundation.Array.Unboxed.Mutable-import           Foundation.Internal.Base-import           Foundation.Internal.MonadTrans-import           Foundation.Internal.Types-import           Foundation.Number-import           Foundation.Primitive.Monad-import           Foundation.Primitive.Types-import qualified Data.List---- | A Array being built chunks by chunks------ The previous buffers are in reverse order, and--- this contains the current buffer and the state of--- progress packing ty inside.-data ArrayBuildingState ty st = ArrayBuildingState-    { prevBuffers   :: [UArray ty]-    , currentBuffer :: MUArray ty st-    , currentOffset :: !(Offset ty)-    , chunkSize     :: !(Size ty)-    }--newtype ArrayBuilder ty st a = ArrayBuilder { runArrayBuilder :: State (ArrayBuildingState ty (PrimState st)) st a }-    deriving (Functor,Applicative,Monad)--appendTy :: (PrimMonad st, PrimType ty, Monad st) => ty -> ArrayBuilder ty st ()-appendTy v = ArrayBuilder $ State $ \st ->-    if offsetAsSize (currentOffset st) == chunkSize st-        then do-            newChunk <- new (chunkSize st)-            cur <- unsafeFreeze (currentBuffer st)-            write newChunk 0 v-            return ((), st { prevBuffers   = cur : prevBuffers st-                           , currentOffset = Offset 1-                           , currentBuffer = newChunk-                           })-        else do-            let (Offset ofs) = currentOffset st-            write (currentBuffer st) ofs v-            return ((), st { currentOffset = currentOffset st + Offset 1 })--build :: (PrimMonad prim, PrimType ty)-      => Int                     -- ^ size of chunks (elements)-      -> ArrayBuilder ty prim () -- ^ ..-      -> prim (UArray ty)-build sizeChunksI origab = call origab (Size sizeChunksI)-  where-    call :: (PrimType ty, PrimMonad prim)-         => ArrayBuilder ty prim () -> Size ty -> prim (UArray ty)-    call ab sizeChunks = do-        m        <- new sizeChunks-        ((), st) <- runState (runArrayBuilder ab) (ArrayBuildingState [] m (Offset 0) sizeChunks)-        current <- unsafeFreezeShrink (currentBuffer st) (offsetAsSize $ currentOffset st)-        return $ mconcat $ Data.List.reverse (current:prevBuffers st)

@@ -9,7 +9,7 @@ import Foundation.Primitive.Monad import Foundation.Array.Common import Foundation.Array.Unboxed.Mutable-import Foundation.Number+import Foundation.Numerical import Control.Monad (forM_) import qualified Foundation.Collection as C 

@@ -36,6 +36,7 @@ import           GHC.Types import           GHC.Ptr import           Foundation.Internal.Base+import qualified Foundation.Internal.Environment as Environment import           Foundation.Internal.Types import           Foundation.Internal.Primitive import           Foundation.Internal.Proxy@@ -43,7 +44,7 @@ import           Foundation.Primitive.Types import           Foundation.Primitive.FinalPtr import           Foundation.Array.Common-import           Foundation.Number+import           Foundation.Numerical -- import           Foreign.Marshal.Utils (copyBytes)  -- | A Mutable array of types built on top of GHC primitive.@@ -118,7 +119,6 @@           where                 !(Size (I# bytes)) = sizeOfE (primSizeInBytes ty) sz         {-# INLINE newFake #-}-{-# INLINE new #-}  newUnpinned :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim)) newUnpinned n = newFake n Proxy@@ -132,12 +132,21 @@  -- | Create a new mutable array of size @n. ----- TODO: heuristic to allocated unpinned (< 1K for example)+-- When memory for a new array is allocated, we decide if that memory region+-- should be pinned (will not be copied around by GC) or unpinned (can be+-- moved around by GC) depending on its size.+--+-- You can change the threshold value used by setting the environment variable+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@. new :: (PrimMonad prim, PrimType ty) => Size ty -> prim (MUArray ty (PrimState prim))-new sz@(Size n)-    | n > 0     = newPinned sz-    | otherwise = newUnpinned sz-+new sz+    | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz+    | otherwise                        = newPinned sz+  where+    -- Safe to use here: If the value changes during runtime, this will only+    -- have an impact on newly created arrays.+    maxSizeUnpinned = Environment.unsafeUArrayUnpinnedMaxSize+{-# INLINE new #-}  mutableSame :: MUArray ty st -> MUArray ty st -> Bool mutableSame (MUVecMA sa ea _ ma) (MUVecMA sb eb _ mb) = and [ sa == sb, ea == eb, bool# (sameMutableByteArray# ma mb)]

@@ -0,0 +1,41 @@+-- Extra bits stuff+module Foundation.Bits+    ( (.<<.)+    , (.>>.)+    , alignRoundUp+    , alignRoundDown+    ) where++import Foundation.Internal.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)

@@ -0,0 +1,83 @@+-- |+-- Module      : Foundation.Class.Bifunctor+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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+  ( Bifunctor(..)+  ) where++#if MIN_VERSION_base(4,8,0)++import Data.Bifunctor (Bifunctor(..))++#else++import           Control.Applicative ( Const(..) )+import           GHC.Generics ( K1(..) )+import qualified Prelude as P++class Bifunctor p where+    {-# MINIMAL bimap | first, second #-}++    -- | Map over both arguments at the same time.+    --+    -- @'bimap' f g ≡ 'first' f '.' 'second' g@+    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d+    bimap f g = first f P.. second g++    -- | Map covariantly over the first argument.+    --+    -- @'first' f ≡ 'bimap' f 'id'@+    first :: (a -> b) -> p a c -> p b c+    first f = bimap f P.id++    -- | Map covariantly over the second argument.+    --+    -- @'second' ≡ 'bimap' 'id'@+    second :: (b -> c) -> p a b -> p a c+    second = bimap P.id+++instance Bifunctor (,) where+    bimap f g ~(a, b) = (f a, g b)++instance Bifunctor ((,,) x1) where+    bimap f g ~(x1, a, b) = (x1, f a, g b)++instance Bifunctor ((,,,) x1 x2) where+    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)++instance Bifunctor ((,,,,) x1 x2 x3) where+    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)++instance Bifunctor ((,,,,,) x1 x2 x3 x4) where+    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)++instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where+    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)+++instance Bifunctor P.Either where+    bimap f _ (P.Left a) = P.Left (f a)+    bimap _ g (P.Right b) = P.Right (g b)++instance Bifunctor Const where+    bimap f _ (Const a) = Const (f a)++instance Bifunctor (K1 i) where+    bimap f _ (K1 c) = K1 (f c)++#endif

@@ -0,0 +1,126 @@+-- |+-- Module      : Foundation.Class.Storable+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+-- Stability   : experimental+-- Portability : portable+--+-- <https://github.com/haskell-foundation/issues/111>+--+--++module Foundation.Class.Storable+    ( Storable(..)+    , StorableFixed(..)++    , Ptr, plusPtr, castPtr+    , peekOff, pokeOff+    ) where++import GHC.Types (Double, Float)++import Foreign.Ptr (castPtr)+import qualified Foreign.Ptr++import Foundation.Internal.Base+import Foundation.Internal.Types+import Foundation.Internal.Proxy+import Foundation.Primitive.Types+import Foundation.Numerical++toProxy :: proxy ty -> Proxy ty+toProxy _ = Proxy++-- | 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 -> Size Word8+    alignment :: proxy a -> Size Word8++plusPtr :: StorableFixed a => Ptr a -> Size a -> Ptr a+plusPtr ptr (Size num) = ptr `Foreign.Ptr.plusPtr` (num * (size ptr `align` alignment ptr))+  where+    align (Size sz) (Size 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)++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 Word32 where+    peek (Ptr addr) = primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0)+instance Storable Word64 where+    peek (Ptr addr) = primAddrRead addr (Offset 0)+    poke (Ptr addr) = primAddrWrite addr (Offset 0)++instance StorableFixed Char where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Double where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Float where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Int8 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Int16 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Int32 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Int64 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Word8 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Word16 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Word32 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy+instance StorableFixed Word64 where+    size      = primSizeInBytes . toProxy+    alignment = primSizeInBytes . toProxy

@@ -15,18 +15,28 @@     , Element     , InnerFunctor(..)     , Foldable(..)+    , Collection(..)+    , NonEmpty+    , getNonEmpty+    , nonEmpty+    , nonEmpty_     , Sequential(..)     , MutableCollection(..)     , IndexedCollection(..)     , KeyedCollection(..)     , Zippable(..)+    , Buildable(..)+    , Builder(..)+    , BuildingState(..)     ) 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.Zippable

@@ -0,0 +1,112 @@+-- |+-- Module      : Foundation.Collection.Buildable+-- License     : BSD-style+-- Maintainer  : foundation+-- Stability   : experimental+-- Portability : portable+--+-- An interface for collections that can be built incrementally.+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Foundation.Collection.Buildable+    ( Buildable(..)+    , Builder(..)+    , BuildingState(..)+    ) where++import           Foundation.Array.Unboxed+import           Foundation.Array.Unboxed.Mutable+import           Foundation.Collection.Element+import           Foundation.Internal.Base+import           Foundation.Internal.MonadTrans+import           Foundation.Internal.Types+import           Foundation.Numerical+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Types++-- $setup+-- >>> import Control.Monad.ST+-- >>> import Foundation.Array.Unboxed+-- >>> import Foundation.Internal.Base+-- >>> import Foundation.Internal.Types++-- | 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 prim ()++  build :: (PrimMonad prim)+        => Int -- ^ Size of a chunk+        -> Builder col prim ()+        -> prim col++newtype Builder col st a = Builder+    { runBuilder :: State (Offset (Step col), BuildingState col (PrimState st)) st a }+    deriving (Functor, Applicative, Monad)++-- | The in-progress state of a building operation.+--+-- The previous buffers are in reverse order, and+-- this contains the current buffer and the state of+-- progress packing the elements inside.+data BuildingState col st = BuildingState+    { prevChunks     :: [col]+    , prevChunksSize :: !(Size (Step col))+    , curChunk       :: Mutable col st+    , chunkSize      :: !(Size (Step col))+    }++instance PrimType ty => Buildable (UArray ty) where+  type Mutable (UArray ty) = MUArray ty+  type Step (UArray ty) = ty++  append v = Builder $ State $ \(i, st) ->+      if offsetAsSize i == chunkSize st+          then do+              cur      <- unsafeFreeze (curChunk st)+              newChunk <- new (chunkSize st)+              unsafeWrite newChunk 0 v+              return ((), (Offset 1, st { prevChunks     = cur : prevChunks st+                                        , prevChunksSize = chunkSize st + prevChunksSize st+                                        , curChunk       = newChunk+                                        }))+          else do+              let Offset i' = i+              unsafeWrite (curChunk st) i' v+              return ((), (i + Offset 1, st))+  {-# INLINE append #-}++  build sizeChunksI ab+    | sizeChunksI <= 0 = build 64 ab+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+        -- Build final array+        let totalSize = prevChunksSize st + offsetAsSize i+        new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze+    where+      sizeChunks = Size sizeChunksI++      fillFromEnd _   []     mua = return mua+      fillFromEnd !end (x:xs) mua = do+          let sz = lengthSize x+          unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz+          fillFromEnd (end - sz) xs mua+  {-# INLINE build #-}

@@ -0,0 +1,109 @@+-- |+-- 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 #-}+module Foundation.Collection.Collection+    ( Collection(..)+    -- * NonEmpty Property+    , NonEmpty+    , getNonEmpty+    , nonEmpty+    , nonEmpty_+    ) where++import           Foundation.Internal.Base+import           Foundation.Collection.Element+import qualified Data.List+import qualified Foundation.Array.Unboxed as UV++-- | NonEmpty property for any Collection+--+-- This can only be made, through the 'nonEmpty' smart contructor+newtype NonEmpty a = NonEmpty { getNonEmpty :: a }+    deriving (Show,Eq)++-- | 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    = error "nonEmpty_: assumption failed: collection is empty. consider using nonEmpty and adding proper cases"+    | otherwise = NonEmpty c++type instance Element (NonEmpty a) = Element a++instance Collection c => IsList (NonEmpty c) where+    type Item (NonEmpty c) = Item c+    toList   = toList . getNonEmpty+    fromList = nonEmpty_ . fromList++-- | A set of methods for ordered colection+class (IsList c, Item c ~ Element c) => Collection c where+    {-# MINIMAL null, length, (elem | notElem), minimum, maximum #-}+    -- | Check if a collection is empty+    null :: c -> Bool+    -- | Length of a collection (number of Element c)+    length :: c -> Int+    -- | 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++instance Collection [a] where+    null = Data.List.null+    length = Data.List.length++    elem = Data.List.elem+    notElem = Data.List.notElem++    minimum = Data.List.minimum . getNonEmpty+    maximum = Data.List.maximum . getNonEmpty++instance UV.PrimType ty => Collection (UV.UArray ty) where+    null = UV.null+    length = UV.length+    elem = UV.elem+    minimum = Data.List.minimum . toList . getNonEmpty+    maximum = Data.List.maximum . toList . getNonEmpty++instance Collection c => Collection (NonEmpty c) where+    null _ = False+    length = length . getNonEmpty+    elem e = elem e . getNonEmpty+    maximum = maximum . getNonEmpty+    minimum = minimum . getNonEmpty

@@ -17,7 +17,7 @@ import qualified Data.List import           Data.Tuple (swap) import           Foundation.Internal.Base-import           Foundation.Number+import           Foundation.Numerical  -- | Simple helper to split a list repeatly when the predicate match wordsWhen     :: (x -> Bool) -> [x] -> [[x]]

@@ -11,33 +11,36 @@  import Foundation.Primitive.Monad import Foundation.Internal.Base+import Foundation.Internal.Types  import qualified Foundation.Array.Unboxed.Mutable as MUV import qualified Foundation.Array.Unboxed as UV --- | Collection of things that can be made mutable, modified and then freezed into an immutable collection+-- | 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, mutWrite, mutRead, mutUnsafeWrite, mutUnsafeRead #-}-    type Collection c+    {-# MINIMAL thaw, freeze, mutNew, mutWrite, mutRead, mutUnsafeWrite, mutUnsafeRead #-}+    type MutableFreezed c     type MutableKey c     type MutableValue c -    unsafeThaw   :: PrimMonad prim => Collection c -> prim (c (PrimState prim))+    unsafeThaw   :: PrimMonad prim => MutableFreezed c -> prim (c (PrimState prim))     unsafeThaw = thaw-    unsafeFreeze :: PrimMonad prim => c (PrimState prim) -> prim (Collection c)+    unsafeFreeze :: PrimMonad prim => c (PrimState prim) -> prim (MutableFreezed c)     unsafeFreeze = freeze -    thaw   :: PrimMonad prim => Collection c -> prim (c (PrimState prim))-    freeze :: PrimMonad prim => c (PrimState prim) -> prim (Collection c)+    thaw   :: PrimMonad prim => MutableFreezed c -> prim (c (PrimState prim))+    freeze :: PrimMonad prim => c (PrimState prim) -> prim (MutableFreezed c) +    mutNew :: PrimMonad prim => Int -> 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 Collection (MUV.MUArray ty) = UV.UArray ty+    type MutableFreezed (MUV.MUArray ty) = UV.UArray ty     type MutableKey (MUV.MUArray ty) = Int     type MutableValue (MUV.MUArray ty) = ty @@ -45,6 +48,8 @@     freeze = UV.freeze     unsafeThaw = UV.unsafeThaw     unsafeFreeze = UV.unsafeFreeze++    mutNew i = MUV.new (Size i)      mutUnsafeWrite = MUV.unsafeWrite     mutUnsafeRead = MUV.unsafeRead

@@ -11,29 +11,29 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DefaultSignatures #-} module Foundation.Collection.Sequential     ( Sequential(..)     ) where  import           Foundation.Internal.Base import           Foundation.Collection.Element+import           Foundation.Collection.Collection import qualified Foundation.Collection.List as ListExtra import qualified Data.List import qualified Foundation.Array.Unboxed as UV  -- | A set of methods for ordered colection-class (IsList c, Item c ~ Element c, Monoid c) => Sequential c where-    {-# MINIMAL null, ((take, drop) | splitAt)+class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where+    {-# MINIMAL ((take, drop) | splitAt)               , ((revTake, revDrop) | revSplitAt)               , splitOn               , (break | span)               , intersperse               , filter, reverse               , uncons, unsnoc, snoc, cons-              , find, sortBy, length, singleton #-}--    -- | Check if a collection is empty-    null :: c -> Bool+              , find, sortBy, singleton+              #-}      -- | Take the first @n elements of a collection     take :: Int -> c -> c@@ -90,6 +90,10 @@     -- | Filter all the elements that satisfy the predicate     filter :: (Element c -> Bool) -> c -> c +    -- | Partition the elements thtat 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 @@ -113,18 +117,52 @@     -- | Sort an ordered collection using the specified order function     sortBy :: (Element c -> Element c -> Ordering) -> c -> c -    -- | Length of a collection (number of Element c)-    length :: c -> Int-     -- | 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)++    -- | 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+ -- Temporary utility functions mconcatCollection :: (Monoid (Item c), Sequential c) => c -> Element c mconcatCollection c = mconcat (toList c)  instance Sequential [a] where-    null = Data.List.null     take = Data.List.take     drop = Data.List.drop     revTake = ListExtra.revTake@@ -136,6 +174,7 @@     intersperse = Data.List.intersperse     span = Data.List.span     filter = Data.List.filter+    partition = Data.List.partition     reverse = Data.List.reverse     uncons = ListExtra.uncons     unsnoc = ListExtra.unsnoc@@ -143,11 +182,11 @@     cons e c = e : c     find = Data.List.find     sortBy = Data.List.sortBy-    length = Data.List.length     singleton = (:[])+    isPrefixOf = Data.List.isPrefixOf+    isSuffixOf = Data.List.isSuffixOf  instance UV.PrimType ty => Sequential (UV.UArray ty) where-    null = UV.null     take = UV.take     revTake = UV.revTake     drop = UV.drop@@ -167,5 +206,4 @@     cons = UV.cons     find = UV.find     sortBy = UV.sortBy-    length = UV.length     singleton = fromList . (:[])

@@ -17,11 +17,10 @@     ) where  import qualified Foundation.Array.Unboxed as UV-import qualified Foundation.Array.Unboxed.Builder as UVB+import           Foundation.Collection.Buildable import           Foundation.Collection.Element import           Foundation.Collection.Sequential import           Foundation.Internal.Base-import           Foundation.Number import qualified Prelude import           GHC.ST @@ -77,14 +76,11 @@ instance Zippable [c]  instance UV.PrimType ty => Zippable (UV.UArray ty) where-  zipWith f as bs = runST $-      Prelude.uncurry UVB.build $ go f (toList as) (toList bs)+  zipWith f as bs = runST $ build 64 $ go f (toList as) (toList bs)     where-      go _  []       _        = (0, return ())-      go _  _        []       = (0, return ())-      go f' (a':as') (b':bs') =-          let (i, builder) = go f' as' bs'-          in (i + 1, UVB.appendTy (f' a' b') >> builder)+      go _  []       _        = return ()+      go _  _        []       = return ()+      go f' (a':as') (b':bs') = append (f' a' b') >> go f' as' bs'  class Zippable col => BoxedZippable col where 

@@ -9,8 +9,11 @@     ( module Foundation.Primitive.FinalPtr     , V.foreignMem     , V.mutableForeignMem+    , module Foreign.C.Types     ) where  import           Foundation.Primitive.FinalPtr import qualified Foundation.Array.Unboxed as V import qualified Foundation.Array.Unboxed.Mutable as V++import           Foreign.C.Types

@@ -0,0 +1,21 @@+-- |+-- 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

@@ -0,0 +1,203 @@+-- |+-- Module      : Foundation.Hashing.FNV.FNV+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : good+--+-- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions)+-- <http://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function>+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE BangPatterns               #-}+module Foundation.Hashing.FNV+    (+    -- * types+      FNV1Hash32(..)+    , FNV1Hash64(..)+    , FNV1_32+    , FNV1a_32+    , FNV1_64+    , FNV1a_64+    ) where++import           Foundation.Internal.Base+import qualified Foundation.Array.Unboxed as A+import           Foundation.Internal.Types+import           Foundation.Primitive.Types+import           Foundation.Numerical+import           Foundation.Hashing.Hasher+import           Data.Bits+import           GHC.Prim+import           GHC.ST+import qualified Prelude++-- | 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` Prelude.fromIntegral b+{-# INLINE xor32 #-}++xor64 :: Word64 -> Word8 -> Word64+xor64 !a !b = a `xor` Prelude.fromIntegral b+{-# INLINE xor64 #-}++newtype FNV1_32 = FNV1_32 Word++newtype FNV1_64 = FNV1_64 Word64++newtype FNV1a_32 = FNV1a_32 Word++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+    hashNew = FNV1_32 0+    hashEnd (FNV1_32 w) = FNV1Hash32 (Prelude.fromIntegral w)+    hashMix8 = fnv1_32_Mix8+    hashMixBytes = fnv1_32_mixBa++instance Hasher FNV1a_32 where+    type HashResult FNV1a_32 = FNV1Hash32+    hashNew = FNV1a_32 0+    hashEnd (FNV1a_32 w) = FNV1Hash32 (Prelude.fromIntegral w)+    hashMix8 = fnv1a_32_Mix8+    hashMixBytes = fnv1a_32_mixBa++instance Hasher FNV1_64 where+    type HashResult FNV1_64 = FNV1Hash64+    hashNew = FNV1_64 0xcbf29ce484222325+    hashEnd (FNV1_64 w) = FNV1Hash64 (Prelude.fromIntegral w)+    hashMix8 = fnv1_64_Mix8+    hashMixBytes = fnv1_64_mixBa++instance Hasher FNV1a_64 where+    type HashResult FNV1a_64 = FNV1Hash64+    hashNew = FNV1a_64 0xcbf29ce484222325+    hashEnd (FNV1a_64 w) = FNV1Hash64 (Prelude.fromIntegral 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 :: ByteArray# -> Offset Word8 -> FNV1_32+    goVec !ma !start = loop start initialState+      where+        !len = start `offsetPlusE` A.lengthSize 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.lengthSize 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 :: ByteArray# -> Offset Word8 -> FNV1a_32+    goVec !ma !start = loop start initialState+      where+        !len = start `offsetPlusE` A.lengthSize 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.lengthSize 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 :: ByteArray# -> Offset Word8 -> FNV1_64+    goVec !ma !start = loop start initialState+      where+        !len = start `offsetPlusE` A.lengthSize 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.lengthSize 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 :: ByteArray# -> Offset Word8 -> FNV1a_64+    goVec !ma !start = loop start initialState+      where+        !len = start `offsetPlusE` A.lengthSize 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.lengthSize ba+        loop !idx !acc+            | idx >= len = acc+            | otherwise  = loop (idx + Offset 1) (hashMix8 (primAddrIndex ptr idx) acc)+    {-# INLINE goAddr #-}

@@ -0,0 +1,108 @@+-- |+-- Module      : Foundation.Hashing.Hashable+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : good+--+-- provide the SipHash algorithm.+-- reference: <http://131002.net/siphash/siphash.pdf>+--+module Foundation.Hashing.Hashable+    ( Hashable(..)+    ) where++import Foundation.Internal.Base+import Foundation.Internal.Natural+import Foundation.Numerical.Primitives+import Foundation.Numerical.Multiplicative+import Foundation.Array+import Foundation.Tuple+import Foundation.String+import Foundation.Collection.Foldable+import Foundation.Hashing.Hasher+import qualified Prelude++-- | 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 Natural where+    hashMix n iacc+        | n == 0    = hashMix8 0 iacc+        | otherwise = loop n iacc+      where+        loop 0 acc = acc+        loop w acc =+            let b = Prelude.fromIntegral w+             in loop (w `div` 256) (hashMix8 b acc)+instance Hashable Int8 where+    hashMix w = hashMix8 (integralConvert w)+instance Hashable Int16 where+    hashMix w = hashMix16 (integralConvert w)+instance Hashable Int32 where+    hashMix w = hashMix32 (integralConvert w)+instance Hashable Int64 where+    hashMix w = hashMix64 (integralConvert w)+instance Hashable Integer where+    hashMix i iacc+        | i == 0    = hashMix8 0 iacc+        | i < 0     = loop (-i) (hashMix8 1 iacc)+        | otherwise = loop i (hashMix8 0 iacc)+      where+        loop 0 acc = acc+        loop w acc =+            let b = Prelude.fromIntegral w+             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 (Array a) where+--    hashMix arr st = 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+-}

@@ -0,0 +1,68 @@+{-# LANGUAGE UnboxedTuples #-}+module Foundation.Hashing.Hasher+    ( Hasher(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Array (UArray)+import qualified Foundation.Array.Unboxed as A+import           Data.Bits+import qualified Prelude++-- | 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, hashMix8, hashEnd #-}++    -- | Associate type when finalizing the state with 'hashEnd'+    type HashResult st++    -- | Create a new Hashing context+    hashNew :: 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, !w2 #) = unWord16 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, !w2, !w3, !w4 #) = unWord32 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, !w2 #) = unWord64_32 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)++unWord16 :: Word16 -> (# Word8, Word8 #)+unWord16 w = (# Prelude.fromIntegral (w `unsafeShiftR` 8)+             ,  Prelude.fromIntegral w #)+{-# INLINE unWord16 #-}++unWord32 :: Word32 -> (# Word8, Word8, Word8, Word8 #)+unWord32 w = (# Prelude.fromIntegral (w `unsafeShiftR` 24)+             ,  Prelude.fromIntegral (w `unsafeShiftR` 16)+             ,  Prelude.fromIntegral (w `unsafeShiftR` 8)+             ,  Prelude.fromIntegral w #)+{-# INLINE unWord32 #-}++unWord64_32 :: Word64 -> (# Word32, Word32 #)+unWord64_32 w = (# Prelude.fromIntegral (w `unsafeShiftR` 32)+                ,  Prelude.fromIntegral w #)+{-# INLINE unWord64_32 #-}

@@ -0,0 +1,285 @@+-- |+-- Module      : Foundation.Hashing.SipHash+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : good+--+-- provide the SipHash algorithm.+-- reference: <http://131002.net/siphash/siphash.pdf>+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Foundation.Hashing.SipHash+    ( SipKey(..)+    , Sip1_3+    , Sip2_4+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Types+import           Foundation.Primitive.Types+import           Foundation.Hashing.Hasher+import qualified Foundation.Array.Unboxed as A+import           Foundation.Array+import           Foundation.Numerical+import           Foundation.Bits+import           Data.Bits+import qualified Prelude+import           GHC.ST+import           GHC.Prim++-- | 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+    hashNew                     = Sip2_4 $ newSipState (SipKey 0 0)+    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+    hashNew                     = Sip1_3 $ newSipState (SipKey 0 0)+    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 !Word64++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 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 = (len .&. 0xff) .<<. 56++-- | 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 = Prelude.fromIntegral $ A.length array8+    array8 = A.unsafeRecast array++    goVec :: ByteArray# -> Offset Word8 -> Sip+    goVec ba start = loop8 initSt initIncr start totalLen+      where+        loop8 !st !incr            _     0 = Sip st incr (currentLen + totalLen)+        loop8 !st !SipIncremental0 !ofs !l+            | l < 8     = loop1 st SipIncremental0 ofs l+            | otherwise =+                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) (l - 8)+        loop8 !st !incr !ofs !l = loop1 st incr ofs l+        loop1 !st !incr _     0 = Sip st incr (currentLen + totalLen)+        loop1 !st !incr !ofs !l =+            let (# st', incr' #) = mix8Prim c (primBaIndex ba ofs) st incr+             in loop1 st' incr' (ofs + Offset 1) (l - 1)++    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+            | l < 8     = loop1 st SipIncremental0 ofs l+            | otherwise =+                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) (l - 8)+        loop8 !st !incr !ofs !l = loop1 st incr ofs l+        loop1 !st !incr _     0 = Sip st incr (currentLen + totalLen)+        loop1 !st !incr !ofs !l =+            let (# st', incr' #) = mix8Prim c (primAddrIndex ptr ofs) st incr+             in loop1 st' incr' (ofs + Offset 1) (l - 1)++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 #-}

@@ -26,7 +26,7 @@ import           Foundation.Internal.Base import           Foundation.String import           Foundation.Array-import           Foundation.Number+import           Foundation.Numerical import qualified Foundation.Array.Unboxed.Mutable as V import qualified Foundation.Array.Unboxed as V import qualified Foundation.String.UTF8 as S

@@ -40,19 +40,30 @@     , Prelude.Int     , Prelude.Integer     , Prelude.Char+    , Foundation.Internal.NumLiteral.Integral (..)+    , Foundation.Internal.NumLiteral.Fractional (..)+    , Foundation.Internal.NumLiteral.HasNegation (..)     , 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+    , Prelude.Double, Prelude.Float     , Prelude.IO+    , FP32+    , FP64     , Foundation.Internal.IsList.IsList (..)     , GHC.Exts.IsString (..)     , GHC.Generics.Generic (..)     , Prelude.Either (..)+    , Data.Data.Data (..)+    , Data.Data.mkNoRepType+    , Data.Data.DataType     , Data.Typeable.Typeable     , Data.Monoid.Monoid (..)     , (Data.Monoid.<>)     , Control.Exception.Exception     , Control.Exception.throw     , Control.Exception.throwIO+    , GHC.Ptr.Ptr(..)+    , ifThenElse     -- * Errors     , internalError     ) where@@ -62,13 +73,24 @@ import qualified Control.Applicative import qualified Control.Exception import qualified Data.Monoid+import qualified Data.Data import qualified Data.Typeable import qualified Data.Word import qualified Data.Int import qualified Foundation.Internal.IsList+import qualified Foundation.Internal.NumLiteral import qualified GHC.Exts import qualified GHC.Generics+import qualified GHC.Ptr  -- | Only to use internally for internal error cases internalError :: [Prelude.Char] -> a internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s)++-- | for support of if .. then .. else+ifThenElse :: Prelude.Bool -> a -> a -> a+ifThenElse Prelude.True  e1 _  = e1+ifThenElse Prelude.False _  e2 = e2++type FP32 = Prelude.Float+type FP64 = Prelude.Double

@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ConstraintKinds #-}+module Foundation.Internal.CallStack+    ( HasCallStack+    ) where++#if MIN_VERSION_base(4,9,0)++import GHC.Stack (HasCallStack)++#elif MIN_VERSION_base(4,8,0)++import qualified GHC.Stack++type HasCallStack = (?callStack :: GHC.Stack.CallStack)++#else++import GHC.Exts (Constraint)++type HasCallStack = (() :: Constraint)++#endif

@@ -0,0 +1,34 @@+-- |+-- Module      : Foundation.Internal.Environment+-- License     : BSD-style+-- Maintainer  : foundation+-- Stability   : experimental+-- Portability : portable+--+-- Global configuration environment+module Foundation.Internal.Environment+    ( unsafeUArrayUnpinnedMaxSize+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Types+import           System.Environment+import           System.IO.Unsafe          (unsafePerformIO)+import           Text.Read++-- | Defines the maximum size in bytes of unpinned arrays.+--+-- You can change this value by setting the environment variable+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number.+--+-- Note: We use 'unsafePerformIO' here. If the environment variable+-- changes during runtime and the runtime system decides to recompute+-- this value, referential transparency is violated (like the First+-- Order violated the Galactic Concordance!).+--+-- TODO The default value of 1024 bytes is arbitrarily chosen for now.+unsafeUArrayUnpinnedMaxSize :: Size8+unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do+    maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"+    return $ maybe (Size 1024) Size maxSize+{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}

@@ -22,8 +22,8 @@ instance Monad m => Applicative (State s m) where     pure a = State $ \st -> return (a,st)     fab <*> fa = State $ \s1 -> do-        (a,s2)  <- runState fa s1-        (ab,s3) <- runState fab s2+        (ab,s2) <- runState fab s1+        (a,s3)  <- runState fa s2         return (ab a, s3) instance Monad m => Monad (State r m) where     return a = State $ \st -> return (a,st)

@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Foundation.Internal.Natural+    ( Natural+    ) where++#if MIN_VERSION_base(4,8,0)++import Numeric.Natural++#else++import Prelude (Show,Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise)+import Data.Typeable++newtype Natural = Natural Integer+    deriving (Show,Eq,Ord,Enum,Typeable)++-- re-create the buggy Num instance for Natural+instance Num Natural where+    fromInteger n+        | n < 0     = error "natural should be positive: "+        | otherwise = Natural n+    (+) (Natural a) (Natural b) = Natural (a + b)+    (-) (Natural a) (Natural b)+        | r < 0     = error "natural should be positve"+        | otherwise = Natural (a - b)+      where r = (a - b)+    (*) (Natural a) (Natural b) = Natural (a * b)+    abs n = n+    negate n = n+    signum (Natural n)+        | n > 0     = 1+        | otherwise = 0++instance Real Natural where+    toRational (Natural n) = toRational n++instance Integral Natural where+    toInteger (Natural n) = n+    divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)+    quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)+    quot (Natural n) (Natural e) = Natural (n `quot` e)+    rem (Natural n) (Natural e) = Natural (n `rem` e)+    div = quot+    mod = rem++#endif

@@ -0,0 +1,117 @@+-- |+-- Module      : Foundation.Internal.NumLiteral+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- Literal support for Integral and Fractional+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Foundation.Internal.NumLiteral+    ( Integral(..)+    , Fractional(..)+    , HasNegation(..)+    ) where++import           Prelude (Int, Integer, Rational, Float, Double)+import           Data.Word (Word8, Word16, Word32, Word64, Word)+import           Data.Int (Int8, Int16, Int32, Int64)+import qualified Prelude+import           Foundation.Internal.Natural+import           Foreign.C.Types+import           System.Posix.Types++-- | Integral Literal support+-- +-- e.g. 123 :: Integer+--      123 :: Word8+class Integral a where+    fromInteger :: Integer -> a++-- | Fractional Literal support+-- +-- e.g. 1.2  :: Double+--      0.03 :: Float+class Fractional a where+    fromRational :: Rational -> a++-- | Negation support+--+-- e.g. -(f x)+class HasNegation a where+    negate :: a -> a++instance Integral Integer where+    fromInteger a = a+instance Integral Natural where+    fromInteger a = Prelude.fromInteger a+instance Integral Int where+    fromInteger a = Prelude.fromInteger a+instance Integral Word where+    fromInteger a = Prelude.fromInteger a+instance Integral Word8 where+    fromInteger a = Prelude.fromInteger a+instance Integral Word16 where+    fromInteger a = Prelude.fromInteger a+instance Integral Word32 where+    fromInteger a = Prelude.fromInteger a+instance Integral Word64 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int8 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int16 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int32 where+    fromInteger a = Prelude.fromInteger a+instance Integral Int64 where+    fromInteger a = Prelude.fromInteger a+instance Integral CSize where+    fromInteger a = Prelude.fromInteger a+instance Integral CInt where+    fromInteger a = Prelude.fromInteger a+instance Integral COff where+    fromInteger a = Prelude.fromInteger a++instance Integral Float where+    fromInteger a = Prelude.fromInteger a+instance Integral Double where+    fromInteger a = Prelude.fromInteger a+instance Integral CFloat where+    fromInteger a = Prelude.fromInteger a+instance Integral CDouble where+    fromInteger a = Prelude.fromInteger a++instance HasNegation Integer where+    negate = Prelude.negate+instance HasNegation Int where+    negate = Prelude.negate+instance HasNegation Int8 where+    negate = Prelude.negate+instance HasNegation Int16 where+    negate = Prelude.negate+instance HasNegation Int32 where+    negate = Prelude.negate+instance HasNegation Int64 where+    negate = Prelude.negate+instance HasNegation Word where+    negate = Prelude.negate+instance HasNegation Word8 where+    negate = Prelude.negate+instance HasNegation Word16 where+    negate = Prelude.negate+instance HasNegation Word32 where+    negate = Prelude.negate+instance HasNegation Word64 where+    negate = Prelude.negate+instance HasNegation CInt where+    negate = Prelude.negate++instance Fractional Rational where+    fromRational a = Prelude.fromRational a+instance Fractional Float where+    fromRational a = Prelude.fromRational a+instance Fractional Double where+    fromRational a = Prelude.fromRational a+instance Fractional CFloat where+    fromRational a = Prelude.fromRational a+instance Fractional CDouble where+    fromRational a = Prelude.fromRational a

@@ -136,9 +136,12 @@ #else compatResizeMutableByteArray# src i s =     case newAlignedPinnedByteArray# i 8# s of { (# s2, dst #) ->-    case copyMutableByteArray# dst 0# src 0# (if isGrow then len else i) s2 of { s3 -> (# s3, dst #) }}+    case copyMutableByteArray# dst 0# src 0# nbBytes s2 of { s3 -> (# s3, dst #) }}   where     isGrow = bool# (i ># len)+    nbBytes+        | isGrow            = len+        | Prelude.otherwise = i     !len = sizeofMutableByteArray# src #endif {-# INLINE compatResizeMutableByteArray# #-}

@@ -5,6 +5,7 @@ -- Stability   : experimental -- Portability : portable --+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Internal.Types     ( FileSize(..)     , Offset(..)@@ -22,25 +23,39 @@ import GHC.Types import GHC.Word import Foundation.Internal.Base-import Foundation.Number+import Foundation.Numerical.Primitives+import Foundation.Numerical.Number+import Foundation.Numerical.Additive+import Foundation.Numerical.Subtractive+import Foundation.Numerical.Multiplicative +-- $setup+-- >>> import Foundation.Array.Unboxed+ -- | File size in bytes newtype FileSize = FileSize Word64     deriving (Show,Eq,Ord)  -- | Offset in bytes used for memory addressing (e.g. in a vector, string, ..)------ Int a terrible backing type which is hard to get away--- considering that GHC/haskell are mostly using this for offset.--- try to bring some sanity by a lightweight wrapping---newtype Offset = Offset Int---    deriving (Show,Eq,Ord) type Offset8 = Offset Word8 --- | Offset in element of a certain type+-- | Offset in a data structure consisting of elements of type 'ty'.+--+-- Int is a terrible backing type which is hard to get away from,+-- considering that GHC/Haskell are mostly using this for offset.+-- Trying to bring some sanity by a lightweight wrapping. newtype Offset ty = Offset Int-    deriving (Show,Eq,Ord)+    deriving (Show,Eq,Ord,Enum) +instance Integral (Offset ty) where+    fromInteger n+        | n < 0     = error "Size: fromInteger: negative"+        | otherwise = Offset . fromInteger $ n+instance IsIntegral (Offset ty) where+    toInteger (Offset i) = toInteger i+instance IsNatural (Offset ty) where+    toNatural (Offset i) = toNatural (intToWord i)+ instance Additive (Offset ty) where     azero = Offset 0     (+) (Offset a) (Offset b) = Offset (a+b)@@ -66,11 +81,18 @@     let (Offset bytes) = offsetOfE szTy ofs      in Offset (bytes `div` szTy2) --- | Size in bytes------ Same caveat as Offset apply here+-- | Size of a data structure in bytes. type Size8 = Size Word8 +instance Integral (Size ty) where+    fromInteger n+        | n < 0     = error "Size: fromInteger: negative"+        | otherwise = Size . fromInteger $ n+instance IsIntegral (Size ty) where+    toInteger (Size i) = toInteger i+instance IsNatural (Size ty) where+    toNatural (Size i) = toNatural (intToWord i)+ instance Additive (Size ty) where     azero = Size 0     (+) (Size a) (Size b) = Size (a+b)@@ -79,9 +101,17 @@     type Difference (Size ty) = Size ty     (Size a) - (Size b) = Size (a-b) --- | Size in element+-- | Size of a data structure.+--+-- More specifically, it represents the number of elements of type `ty` that fit+-- into the data structure.+--+-- >>> lengthSize (fromList ['a', 'b', 'c', '🌟']) :: Size Char+-- Size 4+--+-- Same caveats as 'Offset' apply here. newtype Size ty = Size Int-    deriving (Show,Eq,Ord)+    deriving (Show,Eq,Ord,Enum)  sizeOfE :: Size8 -> Size ty -> Size8 sizeOfE (Size sz) (Size ty) = Size (ty * sz)

@@ -0,0 +1,53 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Foundation.Math.Trigonometry+    ( Trigonometry(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Numerical+import qualified Prelude++class Trigonometry a where+    pi    :: a+    sin   :: a -> a+    cos   :: a -> a+    tan   :: a -> a+    asin  :: a -> a+    acos  :: a -> a+    atan  :: a -> a+    sinh  :: a -> a+    cosh  :: a -> a+    tanh  :: a -> a+    asinh :: a -> a+    acosh :: a -> a+    atanh :: a -> a++instance Trigonometry FP32 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 FP64 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

@@ -1,387 +0,0 @@--- |--- Module      : Foundation.Number--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- 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 DefaultSignatures #-}-module Foundation.Number-    ( Number(..)-    , fromInteger-    , Signed(..)-    , Additive(..)-    , Multiplicative(..)-    , Subtractive(..)-    , Divisible(..)-    , Sign(..)-    ) where--import           Foundation.Internal.Base-import qualified Prelude--infixl 7  *-infixl 6  +, --infixr 8  ^---- | Sign of a signed number-data Sign = Negative | Zero | Positive-    deriving (Eq)--orderingToSign :: Ordering -> Sign-orderingToSign EQ = Zero-orderingToSign GT = Negative-orderingToSign LT = Positive---- | Number literals, convertible through the generic Integer type.------ all number are Enum'erable, meaning that you can move to--- next element-class (Eq a, Ord a, Prelude.Num a, Enum a, Additive a, Subtractive a, Difference a ~ a, Multiplicative a, Divisible a) => Number a where-    {-# MINIMAL toInteger #-}-    --fromInteger  :: Integer -> a-    toInteger    :: a -> Integer---- | convert an Integer to a type having the Number constraint-fromInteger :: Number a => Integer -> a-fromInteger = Prelude.fromInteger---- | Number literals that can be negative-class Number a => Signed a where-    {-# MINIMAL abs, signum #-}-    abs    :: a -> a-    signum :: a -> Sign---- | Represent class of things that can be added together,--- contains a neutral element and is commutative.------ * x + azero = x--- * azero + x = x--- * x + y = y + x----class Additive a where-    {-# MINIMAL azero, (+) #-}-    azero :: a           -- the identity element over addition-    (+)   :: a -> a -> a -- the addition--    scale :: Number n => n -> a -> a -- scale: repeated addition-    default scale :: Number n => n -> a -> a-    scale 0 _ = azero-    scale 1 a = a-    scale 2 a = a + a-    scale n a-        | n < 0     = error "cannot scale by negative number"-        | otherwise = a + scale (pred n) a -- TODO optimise. define by group of 2.---- | Represent class of things that can be multiplied together------ * x * midentity = x--- * midentity * x = x-class Multiplicative a where-    {-# MINIMAL midentity, (*) #-}-    -- | Identity element over multiplication-    midentity :: a--    -- | Multiplication of 2 elements that result in another element-    (*) :: a -> a -> a--    -- | Raise to power, repeated multiplication-    -- e.g.-    -- > a ^ 2 = a * a-    -- > a ^ 10 = (a ^ 5) * (a ^ 5) ..-    (^) :: Number n => a -> n -> a-    (^) = power---- | Represent class of things that can be subtracted.------ Note that the result is not necessary of the same type--- as the operand depending on the actual type.------ For example:--- e.g. (-) :: Int -> Int -> Int---      (-) :: DateTime -> DateTime -> Seconds---      (-) :: Ptr a -> Ptr a -> PtrDiff-class Subtractive a where-    type Difference a-    (-) :: a -> a -> Difference a---- | Represent class of things that can be divided------ (x ‘div‘  y) * y + (x ‘mod‘ y) == x-class Multiplicative a => Divisible a where-    {-# MINIMAL (div, mod) | divMod #-}-    div :: a -> a -> a-    div a b = fst $ divMod a b-    mod :: a -> a -> a-    mod a b = snd $ divMod a b-    divMod :: a -> a -> (a, a)-    divMod a b = (div a b, mod a b)--instance Number Integer where-    toInteger i = i-instance Number Int where-    toInteger i = Prelude.fromIntegral i-instance Number Int8 where-    toInteger i = Prelude.fromIntegral i-instance Number Int16 where-    toInteger i = Prelude.fromIntegral i-instance Number Int32 where-    toInteger i = Prelude.fromIntegral i-instance Number Int64 where-    toInteger i = Prelude.fromIntegral i--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 Number Word where-    toInteger i = Prelude.fromIntegral i-instance Number Word8 where-    toInteger i = Prelude.fromIntegral i-instance Number Word16 where-    toInteger i = Prelude.fromIntegral i-instance Number Word32 where-    toInteger i = Prelude.fromIntegral i-instance Number Word64 where-    toInteger i = Prelude.fromIntegral i--instance Additive Integer where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Int where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Int8 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Int16 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Int32 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Int64 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Word where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Word8 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Word16 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Word32 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum-instance Additive Word64 where-    azero = 0-    (+) = (Prelude.+)-    scale = scaleNum--scaleNum :: (Prelude.Num a, Number n) => n -> a -> a-scaleNum n a = (Prelude.fromIntegral $ toInteger n) Prelude.* a--instance Subtractive Integer where-    type Difference Integer = Integer-    (-) = (Prelude.-)-instance Subtractive Int where-    type Difference Int = Int-    (-) = (Prelude.-)-instance Subtractive Int8 where-    type Difference Int8 = Int8-    (-) = (Prelude.-)-instance Subtractive Int16 where-    type Difference Int16 = Int16-    (-) = (Prelude.-)-instance Subtractive Int32 where-    type Difference Int32 = Int32-    (-) = (Prelude.-)-instance Subtractive Int64 where-    type Difference Int64 = Int64-    (-) = (Prelude.-)-instance Subtractive Word where-    type Difference Word = Word-    (-) = (Prelude.-)-instance Subtractive Word8 where-    type Difference Word8 = Word8-    (-) = (Prelude.-)-instance Subtractive Word16 where-    type Difference Word16 = Word16-    (-) = (Prelude.-)-instance Subtractive Word32 where-    type Difference Word32 = Word32-    (-) = (Prelude.-)-instance Subtractive Word64 where-    type Difference Word64 = Word64-    (-) = (Prelude.-)--instance Multiplicative Integer where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Int where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Int8 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Int16 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Int32 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Int64 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Word where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Word8 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Word16 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Word32 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power-instance Multiplicative Word64 where-    midentity = 1-    (*) = (Prelude.*)-    (^) = power--power :: (Number n, Multiplicative a) => a -> n -> a-power a n-    | n < 0     = error "(^): cannot use negative exponent"-    | n == 0    = midentity-    | otherwise = squaring midentity a n-  where-    squaring y x i-        | i == 0    = y-        | i == 1    = x * y-        | even i    = squaring y (x*x) (i`div`2)-        | otherwise = squaring (x*y) (x*x) (pred i`div` 2)----odd n = (n `mod` 2) /= 0-even :: Number n => n -> Bool-even n = (n `mod` 2) == 0--instance Divisible Integer where-    div = Prelude.div-    mod = Prelude.mod-instance Divisible Int where-    div = Prelude.div-    mod = Prelude.mod-instance Divisible Int8 where-    div = Prelude.div-    mod = Prelude.mod-instance Divisible Int16 where-    div = Prelude.div-    mod = Prelude.mod-instance Divisible Int32 where-    div = Prelude.div-    mod = Prelude.mod-instance Divisible Int64 where-    div = Prelude.div-    mod = Prelude.mod-instance Divisible Word where-    div = Prelude.quot-    mod = Prelude.rem-instance Divisible Word8 where-    div = Prelude.quot-    mod = Prelude.rem-instance Divisible Word16 where-    div = Prelude.quot-    mod = Prelude.rem-instance Divisible Word32 where-    div = Prelude.quot-    mod = Prelude.rem-instance Divisible Word64 where-    div = Prelude.quot-    mod = Prelude.rem---- {-# RULES scaleNum = * #-}----numUpSize :: a -> b---numUpSize-------------------------------------{- haskell numerical classes:- --Prelude> :i Fractional-class Num a => Fractional a where-  (/) :: a -> a -> a-  recip :: a -> a-  fromRational :: Rational -> a-  	-- Defined in ‘GHC.Real’-instance Fractional Float -- Defined in ‘GHC.Float’-instance Fractional Double -- Defined in ‘GHC.Float’--Prelude> :i Integral-class (Real a, Enum a) => Integral a where-  quot :: a -> a -> a-  rem :: a -> a -> a-  div :: a -> a -> a-  mod :: a -> a -> a-  quotRem :: a -> a -> (a, a)-  divMod :: a -> a -> (a, a)-  toInteger :: a -> Integer-  	-- Defined in ‘GHC.Real’-instance Integral Word -- Defined in ‘GHC.Real’-instance Integral Integer -- Defined in ‘GHC.Real’-instance Integral Int -- Defined in ‘GHC.Real’--Prelude> :i Real-class (Num a, Ord a) => Real a where-  toRational :: a -> Rational-  	-- Defined in ‘GHC.Real’-instance Real Word -- Defined in ‘GHC.Real’-instance Real Integer -- Defined in ‘GHC.Real’-instance Real Int -- Defined in ‘GHC.Real’-instance Real Float -- Defined in ‘GHC.Float’-instance Real Double -- Defined in ‘GHC.Float’--}

@@ -0,0 +1,118 @@+-- |+-- Module      : Foundation.Numerical+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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 DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Foundation.Numerical+    ( IsIntegral(..)+    , IsNatural(..)+    , Signed(..)+    , Additive(..)+    , Subtractive(..)+    , Multiplicative(..)+    , IDivisible(..)+    , Divisible(..)+    , Sign(..)+    , recip+    , IntegralRounding(..)+    , FloatingPoint(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Numerical.Number+import           Foundation.Numerical.Additive+import           Foundation.Numerical.Subtractive+import           Foundation.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++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

@@ -0,0 +1,90 @@+{-# LANGUAGE DefaultSignatures #-}+module Foundation.Numerical.Additive+    ( Additive(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Natural+import           Foundation.Numerical.Number+import qualified Prelude++-- | Represent class of things that can be added together,+-- contains a neutral element and is commutative.+--+-- > x + azero = x+-- > azero + x = x+-- > x + y = y + x+--+class Additive a where+    {-# MINIMAL azero, (+) #-}+    azero :: a           -- the identity element over addition+    (+)   :: a -> a -> a -- the addition++    scale :: IsNatural n => n -> a -> a -- scale: repeated addition+    --default scale :: (Prelude.Num n, IsNatural n) => n -> a -> a+    scale 0 _ = azero+    scale 1 a = a+    scale 2 a = a + a+    scale n a = a + scale (pred n) a -- TODO optimise. define by group of 2.++infixl 6 +++instance Additive Integer where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Int where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Int8 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Int16 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Int32 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Int64 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Word where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Natural where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Word8 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Word16 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Word32 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Word64 where+    azero = 0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Prelude.Float where+    azero = 0.0+    (+) = (Prelude.+)+    scale = scaleNum+instance Additive Prelude.Double where+    azero = 0.0+    (+) = (Prelude.+)+    scale = scaleNum++scaleNum :: (Prelude.Num a, IsNatural n) => n -> a -> a+scaleNum n a = (Prelude.fromIntegral $ toNatural n) Prelude.* a

@@ -0,0 +1,30 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Foundation.Numerical.Floating+    ( FloatingPoint(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.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 FP32 where+    floatRadix _ = Prelude.floatRadix (0.0 :: FP32)+    floatDigits _ = Prelude.floatDigits (0.0 :: FP32)+    floatRange _ = Prelude.floatRange (0.0 :: FP32)+    floatDecode = Prelude.decodeFloat+    floatEncode = Prelude.encodeFloat++instance FloatingPoint FP64 where+    floatRadix _ = Prelude.floatRadix (0.0 :: FP64)+    floatDigits _ = Prelude.floatDigits (0.0 :: FP64)+    floatRange _ = Prelude.floatRange (0.0 :: FP64)+    floatDecode = Prelude.decodeFloat+    floatEncode = Prelude.encodeFloat

@@ -0,0 +1,162 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Foundation.Numerical.Multiplicative+    ( Multiplicative(..)+    , IDivisible(..)+    , Divisible(..)+    , recip+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Natural+import           Foundation.Numerical.Number+import           Foundation.Numerical.Additive+import qualified Prelude++-- | Represent class of things that can be multiplied together+--+-- > x * midentity = x+-- > midentity * x = x+class Multiplicative a where+    {-# MINIMAL midentity, (*) #-}+    -- | Identity element over multiplication+    midentity :: a++    -- | Multiplication of 2 elements that result in another element+    (*) :: a -> a -> a++    -- | Raise to power, repeated multiplication+    -- e.g.+    -- > a ^ 2 = a * a+    -- > a ^ 10 = (a ^ 5) * (a ^ 5) ..+    --(^) :: (IsNatural n) => a -> n -> a+    (^) :: (IsNatural n, IDivisible n) => a -> n -> a+    -- default (^) :: (IDivisible n, IsNatural n, Multiplicative a) => a -> n -> a+    (^) = power++-- | Represent types that supports an euclidian division+--+-- > (x ‘div‘ y) * y + (x ‘mod‘ y) == x+class (Additive a, Multiplicative a) => IDivisible a where+    {-# MINIMAL (div, mod) | divMod #-}+    div :: a -> a -> a+    div a b = fst $ divMod a b+    mod :: a -> a -> a+    mod a b = snd $ divMod a b+    divMod :: a -> a -> (a, a)+    divMod a b = (div a b, mod a b)++class Multiplicative a => Divisible a where+    {-# MINIMAL (/) #-}+    (/) :: a -> a -> a++infixl 7  *, /+infixr 8  ^++instance Multiplicative Integer where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int8 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int16 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int32 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Int64 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Natural where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word8 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word16 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word32 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Word64 where+    midentity = 1+    (*) = (Prelude.*)+instance Multiplicative Prelude.Float where+    midentity = 1.0+    (*) = (Prelude.*)+instance Multiplicative Prelude.Double where+    midentity = 1.0+    (*) = (Prelude.*)+instance Multiplicative Prelude.Rational where+    midentity = 1.0+    (*) = (Prelude.*)++instance IDivisible Integer where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int8 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int16 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int32 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Int64 where+    div = Prelude.div+    mod = Prelude.mod+instance IDivisible Natural where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word8 where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word16 where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word32 where+    div = Prelude.quot+    mod = Prelude.rem+instance IDivisible Word64 where+    div = Prelude.quot+    mod = Prelude.rem++instance Divisible Prelude.Rational where+    (/) = (Prelude./)+instance Divisible Float where+    (/) = (Prelude./)+instance Divisible Double where+    (/) = (Prelude./)++recip :: Divisible a => a -> a+recip x = midentity / x++power :: (IsNatural n, IDivisible n, Multiplicative a) => a -> n -> a+power a n+    | n == 0    = midentity+    | otherwise = squaring midentity a n+  where+    squaring y x i+        | i == 0    = y+        | i == 1    = x * y+        | even i    = squaring y (x*x) (i`div`2)+        | otherwise = squaring (x*y) (x*x) (pred i`div` 2)++even :: (IDivisible n, IsIntegral n) => n -> Bool+even n = (n `mod` 2) == 0

@@ -0,0 +1,58 @@+module Foundation.Numerical.Number+    ( IsIntegral(..)+    , IsNatural(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Natural+import qualified Prelude++-- | Number literals, convertible through the generic Integer type.+--+-- all number are Enum'erable, meaning that you can move to+-- next element+class (Enum a, Eq a, Ord a, Integral a) => IsIntegral a where+    {-# MINIMAL toInteger #-}+    toInteger :: a -> Integer++class (Enum a, Eq a, Ord a, Integral a, IsIntegral a) => IsNatural a where+    {-# MINIMAL toNatural #-}+    toNatural :: a -> Natural++instance IsIntegral Integer where+    toInteger i = i+instance IsIntegral Int where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int8 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int16 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int32 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Int64 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Natural where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word8 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word16 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word32 where+    toInteger i = Prelude.toInteger i+instance IsIntegral Word64 where+    toInteger i = Prelude.toInteger i++instance IsNatural Natural where+    toNatural i = i+instance IsNatural Word where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word8 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word16 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word32 where+    toNatural i = Prelude.fromIntegral i+instance IsNatural Word64 where+    toNatural i = Prelude.fromIntegral i

@@ -0,0 +1,30 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+module Foundation.Numerical.Primitives+    ( intToWord+    , integralConvert+    ) where++import GHC.Types+import GHC.Prim+import GHC.Word+import GHC.Int+import qualified Prelude++intToWord :: Int -> Word+intToWord (I# i) = W# (int2Word# i)+{-# INLINE intToWord #-}++class IntegralConvert a b where+    -- lossless integral convertion+    integralConvert :: a -> b++instance IntegralConvert Int8 Word8 where+    integralConvert (I8# i) = W8# (int2Word# i)+instance IntegralConvert Int16 Word16 where+    integralConvert (I16# i) = W16# (int2Word# i)+instance IntegralConvert Int32 Word32 where+    integralConvert (I32# i) = W32# (int2Word# i)+instance IntegralConvert Int64 Word64 where+    integralConvert i = Prelude.fromIntegral i

@@ -0,0 +1,70 @@+module Foundation.Numerical.Subtractive+    ( Subtractive(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Natural+import qualified Prelude++-- | Represent class of things that can be subtracted.+--+--+-- Note that the result is not necessary of the same type+-- as the operand depending on the actual type.+--+-- For example:+--+-- > (-) :: Int -> Int -> Int+-- > (-) :: DateTime -> DateTime -> Seconds+-- > (-) :: Ptr a -> Ptr a -> PtrDiff+-- > (-) :: Natural -> Natural -> Maybe Natural+class Subtractive a where+    type Difference a+    (-) :: a -> a -> Difference a++infixl 6 -++instance Subtractive Integer where+    type Difference Integer = Integer+    (-) = (Prelude.-)+instance Subtractive Int where+    type Difference Int = Int+    (-) = (Prelude.-)+instance Subtractive Int8 where+    type Difference Int8 = Int8+    (-) = (Prelude.-)+instance Subtractive Int16 where+    type Difference Int16 = Int16+    (-) = (Prelude.-)+instance Subtractive Int32 where+    type Difference Int32 = Int32+    (-) = (Prelude.-)+instance Subtractive Int64 where+    type Difference Int64 = Int64+    (-) = (Prelude.-)+instance Subtractive Natural where+    type Difference Natural = Maybe Natural+    (-) a b+        | b > a     = Nothing+        | otherwise = Just (a Prelude.- b)+instance Subtractive Word where+    type Difference Word = Word+    (-) = (Prelude.-)+instance Subtractive Word8 where+    type Difference Word8 = Word8+    (-) = (Prelude.-)+instance Subtractive Word16 where+    type Difference Word16 = Word16+    (-) = (Prelude.-)+instance Subtractive Word32 where+    type Difference Word32 = Word32+    (-) = (Prelude.-)+instance Subtractive Word64 where+    type Difference Word64 = Word64+    (-) = (Prelude.-)+instance Subtractive Prelude.Float where+    type Difference Prelude.Float = Prelude.Float+    (-) = (Prelude.-)+instance Subtractive Prelude.Double where+    type Difference Prelude.Double = Prelude.Double+    (-) = (Prelude.-)

@@ -0,0 +1,278 @@+-- |+-- 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.+--+-- A very simple bytearray parser related to Parsec and Attoparsec+--+-- Simple example:+--+-- > > parse ((,,) <$> take 2 <*> element 0x20 <*> (elements "abc" *> anyElement)) "xx abctest"+-- > ParseOK "est" ("xx", 116)+--++{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}++module Foundation.Parser+    ( Parser(..)+    , Result(..)+    , ParserError(..)+    -- * run the Parser+    , parse+    , parseFeed+    -- * Parser methods+    , hasMore+    , element+    , anyElement+    , elements+    , string+    , take+    , takeWhile+    , takeAll+    , skip+    , skipWhile+    , skipAll+    -- utils+    , optional+    , many, some+    ) where++import           Control.Applicative (Alternative, empty, (<|>), many, some, optional)+import           Control.Monad       (MonadPlus, mzero, mplus)+import           Foundation.Internal.Base+import           Foundation.Collection hiding (take)+import           Foundation.String+import           Foundation.Numerical++data ParserError input+    = Expected+        { expectedInput :: !input+            -- ^ the expected input+        , receivedInput :: !input+           -- ^ but received this data+        }+    | NotEnough+        -- ^ not enough data to complete the parser+    | MonadFail String+        -- ^ only use in the event of Monad.fail function+  deriving (Show, Eq, Ord, Typeable)+instance (Show input, Typeable input) => Exception (ParserError input)++-- | Simple parsing result, that represent respectively:+--+-- * failure: with the error message+--+-- * continuation: that need for more input data+--+-- * success: the remaining unparsed data and the parser value+--+data Result input a =+      ParseFail (ParserError input)+    | ParseMore (Maybe input -> Result input a)+    | ParseOK   input a++instance (Show ba, Show a) => Show (Result ba a) where+    show (ParseFail err) = "ParseFailure: " <> show err+    show (ParseMore _)   = "ParseMore _"+    show (ParseOK b a)   = "ParseOK " <> show a <> " " <> show b++-- | The continuation of the current buffer, and the error string+type Failure input r = input -> ParserError input -> Result input r++-- | The continuation of the next buffer value, and the parsed value+type Success input a r = input -> a -> Result input r++-- | Simple parser structure+newtype Parser input a = Parser+    { runParser :: forall r . input+                           -> Failure input r+                           -> Success input a r+                           -> Result input r }++instance Functor (Parser input) where+    fmap f p = Parser $ \buf err ok ->+       runParser p buf err (\b a -> ok b (f a))+instance Applicative (Parser input) where+    pure      = return+    (<*>) d e = d >>= \b -> e >>= \a -> return (b a)+instance Monad (Parser input) where+    fail errorMsg = Parser $ \buf err _ -> err buf (MonadFail $ fromList errorMsg)+    return v      = Parser $ \buf _ ok -> ok buf v+    m >>= k       = Parser $ \buf err ok ->+        runParser m buf err (\buf' a -> runParser (k a) buf' err ok)+instance MonadPlus (Parser input) where+    mzero = fail "MonadPlus.mzero"+    mplus f g = Parser $ \buf err ok ->+        -- rewrite the err callback of @f to call @g+        runParser f buf (\_ _ -> runParser g buf err ok) ok+instance Alternative (Parser input) where+    empty = fail "Alternative.empty"+    (<|>) = mplus++-- | 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 :: (Sequential input, Monad m)+          => m (Maybe 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 :: Sequential input+      => Parser input a -> input -> Result input a+parse p s = runParser p s (\_ msg -> ParseFail msg) ParseOK++-- When needing more data, getMore append the next data+-- to the current buffer. if no further data, then+-- the err callback is called.+getMore :: Sequential input => Parser input ()+getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk ->+    case nextChunk of+        Nothing -> err buf NotEnough+        Just nc+            | null nc   -> runParser getMore buf err ok+            | otherwise -> ok (mappend buf nc) ()++--+-- Only used by takeAll, which accumulate all the remaining data+-- until ParseMore is fed a Nothing value.+--+-- getAll cannot fail.+getAll :: Sequential input => Parser input ()+getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->+    case nextChunk of+        Nothing -> ok buf ()+        Just nc -> runParser getAll (mappend buf nc) err ok++-- Only used by skipAll, which flush all the remaining data+-- until ParseMore is fed a Nothing value.+--+-- flushAll cannot fail.+flushAll :: Sequential input => Parser input ()+flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->+    case nextChunk of+        Nothing -> ok buf ()+        Just _  -> runParser flushAll mempty err ok++hasMore :: Sequential input => Parser input Bool+hasMore = Parser $ \buf err ok ->+    if null buf+        then ParseMore $ \nextChunk ->+            case nextChunk of+                Nothing -> ok buf False+                Just nc -> runParser hasMore nc err ok+        else ok buf True++-- | Get the next `Element input` from the parser+anyElement :: Sequential input => Parser input (Element input)+anyElement = Parser $ \buf err ok ->+    case uncons buf of+        Nothing      -> runParser (getMore >> anyElement) buf err ok+        Just (c1,b2) -> ok b2 c1++-- | Parse a specific `Element input` at current position+--+-- if the `Element input` is different than the expected one,+-- this parser will raise a failure.+element :: (Sequential input, Eq (Element input))+        => Element input -> Parser input ()+element w = Parser $ \buf err ok ->+    case uncons buf of+        Nothing      -> runParser (getMore >> element w) buf err ok+        Just (c1,b2) | c1 == w   -> ok b2 ()+                     | otherwise -> err buf (Expected (singleton w) (singleton c1))++-- | Parse a sequence of elements from current position+--+-- if the following `Element input` don't match the expected+-- `input` completely, the parser will raise a failure+elements :: (Show input, Eq input, Sequential input) => input -> Parser input ()+elements = consumeEq+  where+    -- partially consume as much as possible or raise an error.+    consumeEq expected = Parser $ \actual err ok ->+        let eLen = length expected in+         if length actual >= eLen+             then    -- enough data for doing a full match+                let (aMatch,aRem) = splitAt eLen actual+                 in if aMatch == expected+                     then ok aRem ()+                     else err actual (Expected expected aMatch)+             else    -- not enough data, match as much as we have, and then recurse.+                let (eMatch, eRem) = splitAt (length actual) expected+                 in if actual == eMatch+                     then runParser (getMore >> consumeEq eRem) mempty err ok+                     else err actual (Expected expected eMatch)++string :: String -> Parser String ()+string !expected = Parser $ \actual err ok ->+    let !expBytes = toBytes UTF8 expected+        !expLen   = length expBytes+        !actBytes = toBytes UTF8 actual+        !actLen   = length actBytes+     in if expLen <= actLen+          then+              let (!aMatch, !aRem) = splitAt expLen actBytes+               in if aMatch == expBytes+                   then ok (fromBytesUnsafe aRem) ()+                   else err actual (Expected expected (fromBytesUnsafe aMatch))+          else+              let (!eMatch, !eRem) = splitAt actLen expBytes+               in if actBytes == eMatch+                   then runParser (getMore >> string (fromBytesUnsafe eRem)) mempty err ok+                   else err actual (Expected expected (fromBytesUnsafe eMatch))++-- | Take @n elements from the current position in the stream+take :: Sequential input => Int -> Parser input input+take n = Parser $ \buf err ok ->+    if length buf >= n+        then let (b1,b2) = splitAt n buf in ok b2 b1+        else runParser (getMore >> take n) buf err ok++-- | Take elements while the @predicate hold from the current position in the+-- stream+takeWhile :: Sequential input => (Element input -> Bool) -> Parser input input+takeWhile predicate = Parser $ \buf err ok ->+    let (b1, b2) = span predicate buf+     in if null b2+            then runParser (getMore >> takeWhile predicate) buf err ok+            else ok b2 b1++-- | Take the remaining elements from the current position in the stream+takeAll :: Sequential input => Parser input input+takeAll = Parser $ \buf err ok ->+    runParser (getAll >> returnBuffer) buf err ok+  where+    returnBuffer = Parser $ \buf _ ok -> ok mempty buf++-- | Skip @n elements from the current position in the stream+skip :: Sequential input => Int -> Parser input ()+skip n = Parser $ \buf err ok ->+    if length buf >= n+        then ok (drop n buf) ()+        else runParser (getMore >> skip (n - length buf)) mempty err ok++-- | Skip `Element input` while the @predicate hold from the current position+-- in the stream+skipWhile :: Sequential input => (Element input -> Bool) -> Parser input ()+skipWhile p = Parser $ \buf err ok ->+    let (_, b2) = span p buf+     in if null b2+            then runParser (getMore >> skipWhile p) mempty err ok+            else ok b2 ()++-- | Skip all the remaining `Element input` from the current position in the+-- stream+skipAll :: Sequential input => Parser input ()+skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok

@@ -28,7 +28,7 @@ import GHC.IO import Foundation.Primitive.Monad import Foundation.Internal.Primitive-import Foundation.Internal.Base (return, Bool(..), (==))+import Foundation.Internal.Base  -- | Create a pointer with an associated finalizer data FinalPtr a = FinalPtr (Ptr a)

@@ -7,8 +7,15 @@ -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-} module Foundation.Primitive.Types     ( PrimType(..)+    , primBaIndex+    , primMbaRead+    , primMbaWrite+    , primArrayIndex+    , primMutableArrayRead+    , primMutableArrayWrite     , primOffsetOfE     , primOffsetRecast     , sizeRecast@@ -20,12 +27,114 @@ import           GHC.Int import           GHC.Types import           GHC.Word+import           Foreign.C.Types import           Foundation.Internal.Proxy import           Foundation.Internal.Base import           Foundation.Internal.Types import           Foundation.Primitive.Monad import qualified Prelude (quot) +#ifdef FOUNDATION_BOUNDS_CHECK++divBytes :: PrimType ty => Offset ty -> (Int -> Int)+divBytes ofs = \x -> x `Prelude.quot` (getSize Proxy ofs)+  where+    getSize :: PrimType ty => Proxy ty -> Offset ty -> Int+    getSize p _ = let (Size sz) = primSizeInBytes p in sz++baLength :: PrimType ty => Offset ty -> ByteArray# -> Int+baLength ofs ba = divBytes ofs (I# (sizeofByteArray# ba))++mbaLength :: PrimType ty => Offset ty -> MutableByteArray# st -> Int+mbaLength ofs ba = divBytes ofs (I# (sizeofMutableByteArray# ba))++aLength :: Array# ty -> Int+aLength ba = I# (sizeofArray# ba)++maLength :: MutableArray# st ty -> Int+maLength ba = I# (sizeofMutableArray# ba)++boundCheckError :: [Char] -> Offset ty -> Int -> a+boundCheckError ty (Offset ofs) len =+    error (ty <> " offset=" <> show ofs <> " len=" <> show len)++baCheck :: PrimType ty => ByteArray# -> Offset ty -> Bool+baCheck ba ofs@(Offset o) = o < 0 || o >= baLength ofs ba++mbaCheck :: PrimType ty => MutableByteArray# st -> Offset ty -> Bool+mbaCheck mba ofs@(Offset o) = o < 0 || o >= mbaLength ofs mba++aCheck :: Array# ty -> Offset ty -> Bool+aCheck ba (Offset o) = o < 0 || o >= aLength ba++maCheck :: MutableArray# st ty -> Offset ty -> Bool+maCheck ma (Offset o) = o < 0 || o >= maLength ma++primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty+primBaIndex ba ofs+    | baCheck ba ofs = boundCheckError "bytearray-index" ofs (baLength ofs ba)+    | otherwise      = primBaUIndex ba ofs+{-# NOINLINE primBaIndex #-}++primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty+primMbaRead mba ofs+    | mbaCheck mba ofs = boundCheckError "mutablebytearray-read" ofs (mbaLength ofs mba)+    | otherwise        = primMbaURead mba ofs+{-# NOINLINE primMbaRead #-}++primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim ()+primMbaWrite mba ofs ty+    | mbaCheck mba ofs = boundCheckError "mutablebytearray-write" ofs (mbaLength ofs mba)+    | otherwise        = primMbaUWrite mba ofs ty+{-# NOINLINE primMbaWrite #-}++primArrayIndex :: Array# ty -> Offset ty -> ty+primArrayIndex a o@(Offset (I# ofs))+    | aCheck a o = boundCheckError "array-index" o (aLength a)+    | otherwise  = let (# v #) = indexArray# a ofs in v+{-# NOINLINE primArrayIndex #-}++primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty+primMutableArrayRead ma o@(Offset (I# ofs))+    | maCheck ma o = boundCheckError "array-read" o (maLength ma)+    | otherwise    = primitive $ \s1 -> readArray# ma ofs s1+{-# NOINLINE primMutableArrayRead #-}++primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim ()+primMutableArrayWrite ma o@(Offset (I# ofs)) v+    | maCheck ma o = boundCheckError "array-write" o (maLength ma)+    | otherwise    = primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #)+{-# NOINLINE primMutableArrayWrite #-}++#else++primBaIndex :: PrimType ty => ByteArray# -> Offset ty -> ty+primBaIndex = primBaUIndex+{-# INLINE primBaIndex #-}++primMbaRead :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> prim ty+primMbaRead = primMbaURead+{-# INLINE primMbaRead #-}++primMbaWrite :: (PrimType ty, PrimMonad prim) => MutableByteArray# (PrimState prim) -> Offset ty -> ty -> prim ()+primMbaWrite = primMbaUWrite+{-# INLINE primMbaWrite #-}++primArrayIndex :: Array# ty -> Offset ty -> ty+primArrayIndex a (Offset (I# ofs)) = let (# v #) = indexArray# a ofs in v+{-# INLINE primArrayIndex #-}++primMutableArrayRead :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> prim ty+primMutableArrayRead ma (Offset (I# ofs)) = primitive $ \s1 -> readArray# ma ofs s1+{-# INLINE primMutableArrayRead #-}++primMutableArrayWrite :: PrimMonad prim => MutableArray# (PrimState prim) ty -> Offset ty -> ty -> prim ()+primMutableArrayWrite ma (Offset (I# ofs)) v =+    primitive $ \s1 -> let !s2 = writeArray# ma ofs v s1 in (# s2, () #)+{-# INLINE primMutableArrayWrite #-}++#endif+ -- | Represent the accessor for types that can be stored in the UArray and MUArray. -- -- Types need to be a instance of storable and have fixed sized.@@ -38,20 +147,20 @@     -----      -- | return the element stored at a specific index-    primBaIndex :: ByteArray# -> Offset ty -> ty+    primBaUIndex :: ByteArray# -> Offset ty -> ty      -----     -- MutableByteArray section     -----      -- | Read an element at an index in a mutable array-    primMbaRead :: PrimMonad prim+    primMbaURead :: PrimMonad prim                 => MutableByteArray# (PrimState prim) -- ^ mutable array to read from                 -> Offset ty                         -- ^ index of the element to retrieve                 -> prim ty                           -- ^ the element returned      -- | Write an element to a specific cell in a mutable array.-    primMbaWrite :: PrimMonad prim+    primMbaUWrite :: PrimMonad prim                  => MutableByteArray# (PrimState prim) -- ^ mutable array to modify                  -> Offset ty                         -- ^ index of the element to modify                  -> ty                                 -- ^ the new value to store@@ -77,17 +186,17 @@                   -> ty                   -> prim () -{-# SPECIALIZE [3] primBaIndex :: ByteArray# -> Offset Word8 -> Word8 #-}+{-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-}  instance PrimType Word8 where     primSizeInBytes _ = Size 1     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W8# w) = primitive $ \s1 -> (# writeWord8Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = W8# (indexWord8OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8OffAddr# addr n s1 in (# s2, W8# r #)@@ -98,12 +207,12 @@ instance PrimType Word16 where     primSizeInBytes _ = Size 2     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W16# w) = primitive $ \s1 -> (# writeWord16Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = W16# (indexWord16OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16OffAddr# addr n s1 in (# s2, W16# r #)@@ -113,12 +222,12 @@ instance PrimType Word32 where     primSizeInBytes _ = Size 4     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W32# w) = primitive $ \s1 -> (# writeWord32Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = W32# (indexWord32OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32OffAddr# addr n s1 in (# s2, W32# r #)@@ -128,12 +237,12 @@ instance PrimType Word64 where     primSizeInBytes _ = Size 8     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = W64# (indexWord64OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64OffAddr# addr n s1 in (# s2, W64# r #)@@ -143,12 +252,12 @@ instance PrimType Int8 where     primSizeInBytes _ = Size 1     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I8# w) = primitive $ \s1 -> (# writeInt8Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = I8# (indexInt8OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8OffAddr# addr n s1 in (# s2, I8# r #)@@ -158,12 +267,12 @@ instance PrimType Int16 where     primSizeInBytes _ = Size 2     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I16# w) = primitive $ \s1 -> (# writeInt16Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = I16# (indexInt16OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16OffAddr# addr n s1 in (# s2, I16# r #)@@ -173,12 +282,12 @@ instance PrimType Int32 where     primSizeInBytes _ = Size 4     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I32# w) = primitive $ \s1 -> (# writeInt32Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = I32# (indexInt32OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32OffAddr# addr n s1 in (# s2, I32# r #)@@ -188,12 +297,12 @@ instance PrimType Int64 where     primSizeInBytes _ = Size 8     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (I64# w) = primitive $ \s1 -> (# writeInt64Array# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = I64# (indexInt64OffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64OffAddr# addr n s1 in (# s2, I64# r #)@@ -204,12 +313,12 @@ instance PrimType Float where     primSizeInBytes _ = Size 4     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (F# w) = primitive $ \s1 -> (# writeFloatArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = F# (indexFloatOffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatOffAddr# addr n s1 in (# s2, F# r #)@@ -219,12 +328,12 @@ instance PrimType Double where     primSizeInBytes _ = Size 8     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (D# w) = primitive $ \s1 -> (# writeDoubleArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = D# (indexDoubleOffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleOffAddr# addr n s1 in (# s2, D# r #)@@ -235,17 +344,48 @@ instance PrimType Char where     primSizeInBytes _ = Size 4     {-# INLINE primSizeInBytes #-}-    primBaIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n)-    {-# INLINE primBaIndex #-}-    primMbaRead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #)-    {-# INLINE primMbaRead #-}-    primMbaWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #)-    {-# INLINE primMbaWrite #-}+    primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n)+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharArray# mba n w s1, () #)+    {-# INLINE primMbaUWrite #-}     primAddrIndex addr (Offset (I# n)) = C# (indexWideCharOffAddr# addr n)     {-# INLINE primAddrIndex #-}     primAddrRead addr (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharOffAddr# addr n s1 in (# s2, C# r #)     {-# INLINE primAddrRead #-}     primAddrWrite addr (Offset (I# n)) (C# w) = primitive $ \s1 -> (# writeWideCharOffAddr# addr n w s1, () #)+    {-# INLINE primAddrWrite #-}++instance PrimType CChar where+    primSizeInBytes _ = Size 1+    {-# INLINE primSizeInBytes #-}+    primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n :: Offset Int8))+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset n) = CChar <$> primMbaURead mba (Offset n :: Offset Int8)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset n) (CChar int8) = primMbaUWrite mba (Offset n) int8+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset n) = CChar $ primAddrIndex addr (Offset n :: Offset Int8)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset n) = CChar <$> primAddrRead addr (Offset n :: Offset Int8)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset n) (CChar int8) = primAddrWrite addr (Offset n) int8+    {-# INLINE primAddrWrite #-}+instance PrimType CUChar where+    primSizeInBytes _ = Size 1+    {-# INLINE primSizeInBytes #-}+    primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8))+    {-# INLINE primBaUIndex #-}+    primMbaURead mba (Offset n) = CUChar <$> primMbaURead mba (Offset n :: Offset Word8)+    {-# INLINE primMbaURead #-}+    primMbaUWrite mba (Offset n) (CUChar w8) = primMbaUWrite mba (Offset n) w8+    {-# INLINE primMbaUWrite #-}+    primAddrIndex addr (Offset n) = CUChar $ primAddrIndex addr (Offset n :: Offset Word8)+    {-# INLINE primAddrIndex #-}+    primAddrRead addr (Offset n) = CUChar <$> primAddrRead addr (Offset n :: Offset Word8)+    {-# INLINE primAddrRead #-}+    primAddrWrite addr (Offset n) (CUChar w8) = primAddrWrite addr (Offset n) w8     {-# INLINE primAddrWrite #-}  -- | Cast a Size linked to type A (Size A) to a Size linked to type B (Size B)

@@ -0,0 +1,123 @@+-- |+-- 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 #-}+module Foundation.Random+    ( MonadRandom(..)+    , MonadRandomState(..)+    , RandomGen(..)+    , withRandomGenerator+    , RNG+    , RNGv1+    ) where++import           Foundation.Internal.Base+import           Foundation.Internal.Types+import           Foundation.Primitive.Monad+import           Foundation.System.Entropy+import           Foundation.Array+import qualified Foundation.Array.Unboxed as A+import qualified Foundation.Array.Unboxed.Mutable as A+import           GHC.ST+import qualified Prelude++-- | A monad constraint that allows to generate random bytes+class (Functor m, Applicative m, Monad m) => MonadRandom m where+    getRandomBytes :: Int -> m (UArray Word8)++instance MonadRandom IO where+    getRandomBytes = getEntropy++-- | A Deterministic Random Generator (DRG) class+class RandomGen gen where+    -- | Initialize a new random generator+    randomNew :: MonadRandom m => m gen++    -- | Generate N bytes of randomness from a DRG+    randomGenerate :: Int -> gen -> (UArray Word8, 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)++-- | 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++-- | 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++-- | 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 RNGv1 = RNGv1 (UArray Word8)++instance RandomGen RNGv1 where+    randomNew = RNGv1 <$> getRandomBytes 32+    randomGenerate = rngv1Generate++rngv1KeySize :: Int+rngv1KeySize = 32++rngv1Generate :: Int -> RNGv1 -> (UArray Word8, RNGv1)+rngv1Generate n (RNGv1 key) = runST $ do+    dst    <- A.newPinned (Size n)+    newKey <- A.newPinned (Size $ rngv1KeySize)+    A.withMutablePtr dst        $ \dstP    ->+        A.withMutablePtr newKey $ \newKeyP ->+        A.withPtr key           $ \keyP    -> do+            _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP (Prelude.fromIntegral n)+            return ()+    (,) <$> A.unsafeFreeze dst+        <*> (RNGv1 <$> 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+                    -> Word32    -- number of bytes to generate+                    -> IO Word32

@@ -12,7 +12,7 @@ -- representation -- -- > {-# LANGUAGE OverloadedStrings #-}--- > s = "Hello World :: String+-- > s = "Hello World" :: String -- -- > s = fromList ("Hello World" :: Prelude.String) :: String --

@@ -0,0 +1,269 @@+-- |+-- Module      : Foundation.String.ASCII+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+-- Stability   : experimental+-- Portability : portable+--+-- A AsciiString type backed by a `ASCII` encoded byte array and all the necessary+-- functions to manipulate the string.+--+-- The recommended type is `AsciiString` from `Foundation.AsciiString.UTF8`+--+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+module Foundation.String.ASCII+    ( AsciiString+    --, Buffer+    , create+    , replicate+    -- * Binary conversion+    , fromBytesUnsafe+    , toBytes+    , copy++    -- * Legacy utility+    , lines+    , words+    ) where++import           Foundation.Array.Unboxed           (UArray)+import qualified Foundation.Array.Unboxed           as Vec+import qualified Foundation.Array.Unboxed.Mutable   as MVec+import qualified Foundation.Collection              as C+import           Foundation.Internal.Base+import           Foundation.Internal.Types+import           Foundation.Numerical+import           Foundation.Primitive.Monad+import           Foundation.Foreign++import GHC.Int+import GHC.Types+import GHC.Prim++ -- temporary+import qualified Data.List+import qualified Prelude+import Foundation.Class.Bifunctor++ccharToChar :: CChar -> Char+ccharToChar (CChar (I8# i)) = C# (chr# i)+charToCChar :: Char -> CChar+charToCChar (C# i) = CChar (I8# (ord# i))++-- | Opaque packed array of characters in the ASCII encoding+newtype AsciiString = AsciiString { toBytes :: UArray CChar }+    deriving (Typeable, Monoid, Eq, Ord)++newtype MutableAsciiString st = MutableAsciiString (MVec.MUArray CChar st)+    deriving (Typeable)++instance Show AsciiString where+    show = fmap ccharToChar . toList+instance IsString AsciiString where+    fromString = fromList . fmap charToCChar+instance IsList AsciiString where+    type Item AsciiString = CChar+    fromList = sFromList+    toList = sToList++type instance C.Element AsciiString = CChar++instance C.InnerFunctor AsciiString where+    imap = ccharMap+instance C.Collection AsciiString where+    null = null+    length = length+    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO faster implementation+    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO faster implementation+    elem x = Data.List.elem x . toList+    notElem x = Data.List.notElem x . toList+instance C.Sequential AsciiString where+    take = take+    drop = drop+    splitAt = splitAt+    revTake = revTake+    revDrop = revDrop+    revSplitAt = revSplitAt+    splitOn = splitOn+    break = break+    breakElem = breakElem+    intersperse = intersperse+    span = span+    filter = filter+    reverse = reverse+    unsnoc = unsnoc+    uncons = uncons+    snoc = snoc+    cons = cons+    find = find+    sortBy = sortBy+    singleton = fromList . (:[])++instance C.Zippable AsciiString where+  -- TODO Use a string builder once available+  zipWith f a b = sFromList (C.zipWith f a b)++next :: AsciiString -> Offset CChar -> (# CChar, Offset CChar #)+next (AsciiString ba) (Offset n) = (# h, Offset (n + 1) #)+  where+    !h = Vec.unsafeIndex ba n++freeze :: PrimMonad prim => MutableAsciiString (PrimState prim) -> prim AsciiString+freeze (MutableAsciiString mba) = AsciiString `fmap` C.unsafeFreeze mba+{-# INLINE freeze #-}++------------------------------------------------------------------------+-- real functions++sToList :: AsciiString -> [CChar]+sToList s = loop azero+  where+    nbBytes :: Size CChar+    !nbBytes = size s+    !end = azero `offsetPlusE` nbBytes+    loop idx+        | idx == end = []+        | otherwise  =+            let (# c , idx' #) = next s idx in c : loop idx'++sFromList :: [CChar] -> AsciiString+sFromList = AsciiString . fromList+{-# INLINE [0] sFromList #-}++null :: AsciiString -> Bool+null  = Vec.null . toBytes+{-# INLINE null #-}++-- | Create a string composed of a number @n of Chars (Unicode code points).+--+-- if the input @s contains less characters than required, then+take :: Int -> AsciiString -> AsciiString+take n s = fst $ splitAt n s -- TODO specialize+{-# INLINE take #-}++-- | Create a string with the remaining Chars after dropping @n Chars from the beginning+drop :: Int -> AsciiString -> AsciiString+drop n = AsciiString . Vec.drop n . toBytes+{-# INLINE drop #-}++splitAt :: Int -> AsciiString -> (AsciiString, AsciiString)+splitAt n = bimap AsciiString AsciiString . Vec.splitAt n . toBytes+{-# INLINE splitAt #-}++-- rev{Take,Drop,SplitAt} TODO optimise:+-- we can process the string from the end using a skipPrev instead of getting the length++revTake :: Int -> AsciiString -> AsciiString+revTake nbElems v = drop (length v - nbElems) v++revDrop :: Int -> AsciiString -> AsciiString+revDrop nbElems v = take (length v - nbElems) v++revSplitAt :: Int -> AsciiString -> (AsciiString, AsciiString)+revSplitAt n v = (drop idx v, take idx v)+  where idx = length v - n++-- | Split on the input string using the predicate as separator+--+-- e.g.+--+-- > splitOn (== ',') ","          == ["",""]+-- > splitOn (== ',') ",abc,"      == ["","abc",""]+-- > splitOn (== ':') "abc"        == ["abc"]+-- > splitOn (== ':') "abc::def"   == ["abc","","def"]+-- > splitOn (== ':') "::abc::def" == ["","","abc","","def"]+--+splitOn :: (CChar -> Bool) -> AsciiString -> [AsciiString]+splitOn predicate = fmap AsciiString . Vec.splitOn predicate . toBytes++break :: (CChar -> Bool) -> AsciiString -> (AsciiString, AsciiString)+break predicate = bimap AsciiString AsciiString . Vec.break predicate . toBytes+{-# INLINE[0] break #-}++{-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-}++breakElem :: CChar -> AsciiString -> (AsciiString, AsciiString)+breakElem !el (AsciiString ba) =+    let (# v1,v2 #) = Vec.splitElem el ba in (AsciiString v1, AsciiString v2)+{-# INLINE breakElem #-}++intersperse :: CChar -> AsciiString -> AsciiString+intersperse sep = AsciiString . Vec.intersperse sep . toBytes++span :: (CChar -> Bool) -> AsciiString -> (AsciiString, AsciiString)+span predicate = break (not . predicate)++-- | size in bytes+size :: AsciiString -> Size CChar+size = Size . C.length . toBytes++length :: AsciiString -> Int+length s = let (Size l) = size s in l++replicate :: Int -> CChar -> AsciiString+replicate n c = AsciiString $ Vec.create n (const c)++-- | Copy the AsciiString+copy :: AsciiString -> AsciiString+copy (AsciiString s) = AsciiString (Vec.copy s)++-- | Allocate a MutableAsciiString of a specific size in bytes.+new :: PrimMonad prim+    => Size CChar -- ^ in number of bytes, not of elements.+    -> prim (MutableAsciiString (PrimState prim))+new n = MutableAsciiString `fmap` MVec.new n++create :: PrimMonad prim => Int -> (MutableAsciiString (PrimState prim) -> prim Int) -> prim AsciiString+create sz f = do+    ms     <- new (Size sz)+    filled <- f ms+    if filled == sz+        then freeze ms+        else C.take filled `fmap` freeze ms++ccharMap :: (CChar -> CChar) -> AsciiString -> AsciiString+ccharMap f = AsciiString . Vec.map f . toBytes++snoc :: AsciiString -> CChar -> AsciiString+snoc (AsciiString ba) = AsciiString . Vec.snoc ba++cons :: CChar -> AsciiString -> AsciiString+cons c = AsciiString . Vec.cons c . toBytes++unsnoc :: AsciiString -> Maybe (AsciiString, CChar)+unsnoc str = first AsciiString <$> Vec.unsnoc (toBytes str)++uncons :: AsciiString -> Maybe (CChar, AsciiString)+uncons str = second AsciiString <$> Vec.uncons (toBytes str)++find :: (CChar -> Bool) -> AsciiString -> Maybe CChar+find predicate = Vec.find predicate . toBytes++sortBy :: (CChar -> CChar -> Ordering) -> AsciiString -> AsciiString+sortBy sortF = AsciiString . Vec.sortBy sortF . toBytes++filter :: (CChar -> Bool) -> AsciiString -> AsciiString+filter p s = fromList $ Data.List.filter p $ toList s++reverse :: AsciiString -> AsciiString+reverse (AsciiString ba) = AsciiString $ Vec.reverse ba++-- | Convert a Byte Array representing UTF8 data directly to a string without checking for UTF8 validity+--+-- If the input contains invalid sequences, it will trigger runtime async errors when processing data.+--+-- In doubt, use 'fromBytes'+fromBytesUnsafe :: UArray CChar -> AsciiString+fromBytesUnsafe = AsciiString++lines :: AsciiString -> [AsciiString]+lines = fmap fromString . Prelude.lines . show++words :: AsciiString -> [AsciiString]+words = fmap fromString . Prelude.words . show

@@ -15,13 +15,14 @@  import Foundation.Internal.Base import Foundation.Internal.Types-import Foundation.Number+import Foundation.Numerical import Foundation.Primitive.Monad  import GHC.Prim import GHC.Word import GHC.Types-import Foundation.Array.Unboxed.Builder+import Foundation.Array.Unboxed+import Foundation.Collection.Buildable  import Foundation.String.Encoding.Encoding @@ -77,9 +78,9 @@       => Char            -- ^ expecting it to be a valid Ascii character.            -- otherwise this function will throw an exception-      -> ArrayBuilder Word8 st ()+      -> Builder (UArray Word8) st () write c-    | c < toEnum 0x80 = appendTy $ w8 c+    | c < toEnum 0x80 = append $ w8 c     | otherwise       = throw $ CharNotAscii c   where     w8 :: Char -> Word8

@@ -17,9 +17,9 @@ import Foundation.Internal.Types import Foundation.Primitive.Monad import Foundation.Primitive.Types-import Foundation.Array.Unboxed.Builder-import Foundation.Number+import Foundation.Numerical import qualified Foundation.Collection as C+import           Foundation.Collection.Buildable import           Foundation.Array.Unboxed (UArray) import qualified Foundation.Array.Unboxed as Vec @@ -61,7 +61,7 @@                       -- ^ only used for type deduction                   -> Char                       -- ^ the unicode character to encode-                  -> ArrayBuilder (Unit encoding) st ()+                  -> Builder (UArray (Unit encoding)) st ()  -- | helper to convert a given Array in a given encoding into an array -- with another encoding.

@@ -15,13 +15,14 @@  import Foundation.Internal.Base import Foundation.Internal.Types-import Foundation.Number+import Foundation.Numerical import Foundation.Primitive.Monad  import GHC.Prim import GHC.Word import GHC.Types-import Foundation.Array.Unboxed.Builder+import Foundation.Array.Unboxed+import Foundation.Collection.Buildable  import Foundation.String.Encoding.Encoding @@ -53,10 +54,10 @@  write :: (PrimMonad st, Monad st)       => Char-      -> ArrayBuilder Word8 st ()+      -> Builder (UArray Word8) st () write c@(C# ch)-    | c <= toEnum 0xFF = appendTy (W8# x)-    | otherwise       = throw $ NotISO_8859_1 c+    | c <= toEnum 0xFF = append (W8# x)+    | otherwise        = throw $ NotISO_8859_1 c   where     x :: Word#     !x = int2Word# (ord# ch)

@@ -17,10 +17,11 @@ import GHC.Prim import GHC.Word import GHC.Types-import Foundation.Number+import Foundation.Numerical import Data.Bits import qualified Prelude-import Foundation.Array.Unboxed.Builder+import Foundation.Array.Unboxed+import Foundation.Collection.Buildable  import Foundation.String.Encoding.Encoding @@ -75,12 +76,12 @@  write :: (PrimMonad st, Monad st)       => Char-      -> ArrayBuilder Word16 st ()+      -> Builder (UArray Word16) st () write c-    | c < toEnum 0xd800   = appendTy $ w16 c-    | c > toEnum 0x10000  = let (w1, w2) = wHigh c in appendTy w1 >> appendTy w2+    | c < toEnum 0xd800   = append $ w16 c+    | c > toEnum 0x10000  = let (w1, w2) = wHigh c in append w1 >> append w2     | c > toEnum 0x10ffff = throw $ InvalidUnicode c-    | c >= toEnum 0xe000  = appendTy $ w16 c+    | c >= toEnum 0xe000  = append $ w16 c     | otherwise = throw $ InvalidUnicode c   where     w16 :: Char -> Word16

@@ -17,8 +17,9 @@ import GHC.Prim import GHC.Word import GHC.Types-import Foundation.Number-import Foundation.Array.Unboxed.Builder+import Foundation.Numerical+import Foundation.Array.Unboxed+import Foundation.Collection.Buildable  import Foundation.String.Encoding.Encoding @@ -45,8 +46,8 @@  write :: (PrimMonad st, Monad st)       => Char-      -> ArrayBuilder Word32 st ()-write c = appendTy w32+      -> Builder (UArray Word32) st ()+write c = append w32   where     !(C# ch) = c     w32 :: Word32

@@ -14,29 +14,25 @@ -- The String data must contain UTF8 valid data. -- -{-# LANGUAGE MagicHash #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash        #-} module Foundation.String.ModifiedUTF8     ( fromModified     ) where  import           GHC.ST (runST, ST) import           GHC.Prim (Addr#)-import           GHC.Ptr (Ptr(..))-import qualified Control.Monad (mapM)+import           Control.Monad (mapM_)  import           Foundation.Internal.Base import           Foundation.Internal.Types import qualified Foundation.Array.Unboxed as Vec import           Foundation.Array.Unboxed (UArray)-import           Foundation.Number-import           Foundation.Array.Unboxed.Builder+import           Foundation.Collection.Buildable+import           Foundation.Numerical import           Foundation.Primitive.FinalPtr import           Foundation.String.UTF8Table --- offset of size one-aone :: Offset Word8-aone = Offset 1- -- helper function to read some bytes from the given byte reader accessBytes :: Offset Word8 -> (Offset Word8 -> Word8) -> ([Word8], Offset Word8) accessBytes offset getAtIdx = (loop offset, pastEnd)@@ -44,11 +40,11 @@     nbytes :: Size Word8     nbytes = Size $ getNbBytes $ getAtIdx offset     pastEnd :: Offset Word8-    pastEnd = aone + (offset `offsetPlusE` nbytes)+    pastEnd = 1 + (offset `offsetPlusE` nbytes)     loop :: Offset Word8 -> [Word8]     loop off         | off == pastEnd = []-        | otherwise      = getAtIdx off : loop (off + aone)+        | otherwise      = getAtIdx off : loop (off + 1)  buildByteArray :: Addr# -> ST st (UArray Word8) buildByteArray addr = Vec.UVecAddr (Offset 0) (Size 100000) `fmap`@@ -68,12 +64,13 @@   where     buildWithBytes getAt = build 64 $ loopBuilder getAt (Offset 0)     loopBuilder getAt offset =-        let (bs, noffset) = accessBytes offset getAt-         in case bs of-              [] -> internalError "ModifiedUTF8.fromModified"-              [0x00] -> return ()-              [b1,b2] | b1 == 0xC0 && b2 == 0x80 -> appendTy 0x00 >> loopBuilder getAt noffset-              _ -> Control.Monad.mapM appendTy bs >> loopBuilder getAt noffset+        case bs of+            [] -> internalError "ModifiedUTF8.fromModified"+            [0x00] -> return ()+            [b1,b2] | b1 == 0xC0 && b2 == 0x80 -> append 0x00 >> loopBuilder getAt noffset+            _ -> mapM_ append bs >> loopBuilder getAt noffset+      where+        (bs, noffset) = accessBytes offset getAt  {- toModified :: ByteArray -> ByteArray

@@ -20,6 +20,7 @@ {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE UnboxedTuples              #-} {-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-} module Foundation.String.UTF8     ( String(..)     --, Buffer@@ -33,6 +34,7 @@     , fromBytesLenient     , toBytes     , mutableValidate+    , copy     , ValidationFailure(..)     -- * Legacy utility     , lines@@ -44,10 +46,12 @@ import           Foundation.Array.Unboxed.ByteArray (MutableByteArray) import qualified Foundation.Array.Unboxed.Mutable   as MVec import qualified Foundation.Collection              as C+import           Foundation.Collection.Buildable import           Foundation.Internal.Base+import           Foundation.Internal.MonadTrans import           Foundation.Internal.Primitive import           Foundation.Internal.Types-import           Foundation.Number+import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           Foundation.String.UTF8Table@@ -55,7 +59,7 @@ import           GHC.ST import           GHC.Types import           GHC.Word-import           Foundation.Array.Unboxed.Builder (ArrayBuilder, appendTy)+import           GHC.Char   -- temporary import qualified Data.List@@ -76,6 +80,14 @@ newtype String = String (UArray Word8)     deriving (Typeable, Monoid, Eq, Ord) +instance Data String where+    toConstr s   = mkConstr stringType (show s) [] Prefix+    dataTypeOf _ = stringType+    gunfold _ _  = error "gunfold"++stringType :: DataType+stringType = mkNoRepType "Foundation.String"+ newtype MutableString st = MutableString (MutableByteArray st)     deriving (Typeable) @@ -92,8 +104,13 @@  instance C.InnerFunctor String where     imap = charMap-instance C.Sequential String where+instance C.Collection String where     null = null+    length = length+    elem = elem+    minimum = Data.List.minimum . toList . C.getNonEmpty -- TODO faster implementation+    maximum = Data.List.maximum . toList . C.getNonEmpty -- TODO faster implementation+instance C.Sequential String where     take = take     drop = drop     splitAt = splitAt@@ -113,13 +130,57 @@     cons = cons     find = find     sortBy = sortBy-    length = length     singleton = fromList . (:[])  instance C.Zippable String where-  -- TODO Use a string builder once available-  zipWith f a b = sFromList (C.zipWith f a b)+  zipWith f as bs = runST $ build 64 $ go f (toList as) (toList bs)+    where+      go _  []       _        = return ()+      go _  _        []       = return ()+      go f' (a':as') (b':bs') = append (f' a' b') >> go f' as' bs' +instance Buildable String where+  type Mutable String = MutableString+  type Step String = Word8++  append c = Builder $ State $ \(i, st) ->+      if offsetAsSize i + nbBytes >= chunkSize st+          then do+              cur      <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+              newChunk <- new (chunkSize st)+              writeUTF8Char newChunk (Offset 0) utf8Char+              return ((), (sizeAsOffset nbBytes, st { prevChunks     = cur : prevChunks st+                                                    , prevChunksSize = offsetAsSize i + prevChunksSize st+                                                    , curChunk       = newChunk+                                                    }))+          else do+              writeUTF8Char (curChunk st) i utf8Char+              return ((), (i + sizeAsOffset nbBytes, st))+    where+      utf8Char = asUTF8Char c+      nbBytes  = numBytes utf8Char+  {-# INLINE append #-}++  build sizeChunksI sb+    | sizeChunksI <= 3 = build 64 sb+    | otherwise        = do+        first         <- new sizeChunks+        ((), (i, st)) <- runState (runBuilder sb) (Offset 0, BuildingState [] (Size 0) first sizeChunks)+        cur           <- unsafeFreezeShrink (curChunk st) (offsetAsSize i)+        -- Build final array+        let totalSize = prevChunksSize st + offsetAsSize i+        final <- Vec.new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= Vec.unsafeFreeze+        return $ String final+    where+      sizeChunks = Size sizeChunksI++      fillFromEnd _   []            mba = return mba+      fillFromEnd !end (String x:xs) mba = do+          let sz = Vec.lengthSize x+          Vec.unsafeCopyAtRO mba (sizeAsOffset (end - sz)) x (Offset 0) sz+          fillFromEnd (end - sz) xs mba+  {-# INLINE build #-}+ data ValidationFailure = InvalidHeader                        | InvalidContinuation                        | MissingByte@@ -160,26 +221,26 @@          one pos =             case nbConts of-                0    -> (pos + o1, Nothing)+                0    -> (pos + 1, Nothing)                 0xff -> (pos, Just InvalidHeader)-                _ | (pos + o1) `offsetPlusE` nbContsE > end -> (pos, Just MissingByte)+                _ | (pos + 1) `offsetPlusE` nbContsE > end -> (pos, Just MissingByte)                 1    ->-                    let c1 = getIdx (pos + o1)+                    let c1 = getIdx (pos + 1)                      in if isContinuation c1-                            then (pos + Offset 2, Nothing)+                            then (pos + 2, Nothing)                             else (pos, Just InvalidContinuation)                 2 ->-                    let c1 = getIdx (pos + o1)-                        c2 = getIdx (pos + Offset 2)+                    let c1 = getIdx (pos + 1)+                        c2 = getIdx (pos + 2)                      in if isContinuation c1 && isContinuation c2-                            then (pos + Offset 3, Nothing)+                            then (pos + 3, Nothing)                             else (pos, Just InvalidContinuation)                 3 ->-                    let c1 = getIdx (pos + Offset 1)-                        c2 = getIdx (pos + Offset 2)-                        c3 = getIdx (pos + Offset 3)+                    let c1 = getIdx (pos + 1)+                        c2 = getIdx (pos + 2)+                        c3 = getIdx (pos + 3)                      in if isContinuation c1 && isContinuation c2 && isContinuation c3-                            then (pos + Offset 4, Nothing)+                            then (pos + 4, Nothing)                             else (pos, Just InvalidContinuation)                 _ -> error "internal error"           where@@ -187,8 +248,6 @@             !nbContsE@(Size nbConts) = Size $ getNbBytes h     {-# INLINE go #-} -    o1 = Offset 1- mutableValidate :: PrimMonad prim                 => MutableByteArray (PrimState prim)                 -> Int@@ -238,10 +297,13 @@                                 else return (pos, Just InvalidContinuation)                         _ -> error "internal error" -skipNext :: String -> Int -> Int-skipNext (String ba) n = n + 1 + getNbBytes h-  where-    !h = Vec.unsafeIndex ba n+skipNextHeaderValue :: Word8 -> Size Word8+skipNextHeaderValue !x+    | x < 0xC0  = Size 1 -- 0b11000000+    | x < 0xE0  = Size 2 -- 0b11100000+    | x < 0xF0  = Size 3 -- 0b11110000+    | otherwise = Size 4+{-# INLINE skipNextHeaderValue #-}  nextWithIndexer :: (Offset Word8 -> Word8)                 -> Offset Word8@@ -285,7 +347,7 @@  writeWithBuilder :: (PrimMonad st, Monad st)                  => Char-                 ->  ArrayBuilder Word8 st ()+                 -> Builder (UArray Word8) st () writeWithBuilder c =     if      bool# (ltWord# x 0x80##   ) then encode1     else if bool# (ltWord# x 0x800##  ) then encode2@@ -295,30 +357,29 @@     !(I# xi) = fromEnum c     !x       = int2Word# xi -    encode1 = appendTy (W8# x)+    encode1 = append (W8# x)      encode2 = do         let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##             x2  = toContinuation x-        appendTy (W8# x1) >> appendTy (W8# x2)+        append (W8# x1) >> append (W8# x2)      encode3 = do         let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##             x2  = toContinuation (uncheckedShiftRL# x 6#)             x3  = toContinuation x-        appendTy (W8# x1) >> appendTy (W8# x2) >> appendTy (W8# x3)+        append (W8# x1) >> append (W8# x2) >> append (W8# x3)      encode4 = do         let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##             x2  = toContinuation (uncheckedShiftRL# x 12#)             x3  = toContinuation (uncheckedShiftRL# x 6#)             x4  = toContinuation x-        appendTy (W8# x1) >> appendTy (W8# x2) >> appendTy (W8# x3) >> appendTy (W8# x4)+        append (W8# x1) >> append (W8# x2) >> append (W8# x3) >> append (W8# x4)      toContinuation :: Word# -> Word#     toContinuation w = or# (and# w 0x3f##) 0x80## - next :: String -> Offset8 -> (# Char, Offset8 #) next (String ba) (Offset n) =     case getNbBytes# h of@@ -329,7 +390,7 @@         3# -> (# toChar (decode4 (Vec.unsafeIndex ba (n + 1))                                  (Vec.unsafeIndex ba (n + 2))                                  (Vec.unsafeIndex ba (n + 3))) , Offset $ n + 4 #)-        r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h))+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show (I# r) <> " h=" <> show (W# h))   where     !(W8# h) = Vec.unsafeIndex ba n @@ -362,35 +423,60 @@     | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8     | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 -writeBytes :: Char -> UTF8Char-writeBytes c =-    if      bool# (ltWord# x 0x80##   ) then encode1-    else if bool# (ltWord# x 0x800##  ) then encode2-    else if bool# (ltWord# x 0x10000##) then encode3-    else                                     encode4-  where-    !(I# xi) = fromEnum c-    !x       = int2Word# xi-    encode1 = UTF8_1 (W8# x)-    encode2 =-        let !x1  = W8# (or# (uncheckedShiftRL# x 6#) 0xc0##)-            !x2  = toContinuation x-         in UTF8_2 x1 x2-    encode3 =-        let !x1  = W8# (or# (uncheckedShiftRL# x 12#) 0xe0##)-            !x2  = toContinuation (uncheckedShiftRL# x 6#)-            !x3  = toContinuation x-         in UTF8_3 x1 x2 x3-    encode4 =-        let !x1  = W8# (or# (uncheckedShiftRL# x 18#) 0xf0##)-            !x2  = toContinuation (uncheckedShiftRL# x 12#)-            !x3  = toContinuation (uncheckedShiftRL# x 6#)-            !x4  = toContinuation x-         in UTF8_4 x1 x2 x3 x4-    toContinuation :: Word# -> Word8-    toContinuation w = W8# (or# (and# w 0x3f##) 0x80##)-    {-# INLINE toContinuation #-}+asUTF8Char :: Char -> UTF8Char+asUTF8Char !c+  | bool# (ltWord# x 0x80##   ) = encode1+  | bool# (ltWord# x 0x800##  ) = encode2+  | bool# (ltWord# x 0x10000##) = encode3+  | otherwise                   = encode4+    where+      !(I# xi) = fromEnum c+      !x       = int2Word# xi +      encode1 = UTF8_1 (W8# x)+      encode2 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 6#) 0xc0##)+              !x2 = toContinuation x+           in UTF8_2 x1 x2+      encode3 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 12#) 0xe0##)+              !x2 = toContinuation (uncheckedShiftRL# x 6#)+              !x3 = toContinuation x+           in UTF8_3 x1 x2 x3+      encode4 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 18#) 0xf0##)+              !x2 = toContinuation (uncheckedShiftRL# x 12#)+              !x3 = toContinuation (uncheckedShiftRL# x 6#)+              !x4 = toContinuation x+           in UTF8_4 x1 x2 x3 x4++      toContinuation :: Word# -> Word8+      toContinuation w = W8# (or# (and# w 0x3f##) 0x80##)+      {-# INLINE toContinuation #-}++numBytes :: UTF8Char -> Size8+numBytes UTF8_1{} = Size 1+numBytes UTF8_2{} = Size 2+numBytes UTF8_3{} = Size 3+numBytes UTF8_4{} = Size 4++writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim ()+writeUTF8Char (MutableString mba) (Offset i) (UTF8_1 x1) =+        C.mutUnsafeWrite mba i     x1+writeUTF8Char (MutableString mba) (Offset i) (UTF8_2 x1 x2) = do+        C.mutUnsafeWrite mba i     x1+        C.mutUnsafeWrite mba (i+1) x2+writeUTF8Char (MutableString mba) (Offset i) (UTF8_3 x1 x2 x3) = do+        C.mutUnsafeWrite mba i     x1+        C.mutUnsafeWrite mba (i+1) x2+        C.mutUnsafeWrite mba (i+2) x3+writeUTF8Char (MutableString mba) (Offset i) (UTF8_4 x1 x2 x3 x4) = do+        C.mutUnsafeWrite mba i     x1+        C.mutUnsafeWrite mba (i+1) x2+        C.mutUnsafeWrite mba (i+2) x3+        C.mutUnsafeWrite mba (i+3) x4+{-# INLINE writeUTF8Char #-}+ write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 write (MutableString mba) (Offset i) c =     if      bool# (ltWord# x 0x80##   ) then encode1@@ -432,11 +518,16 @@      toContinuation :: Word# -> Word#     toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE write #-}  freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba {-# INLINE freeze #-} +unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> Size Word8 -> prim String+unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s+{-# INLINE unsafeFreezeShrink #-}+ ------------------------------------------------------------------------ -- real functions @@ -450,7 +541,6 @@         | otherwise  =             let (# c , idx' #) = next s idx in c : loop idx' - {-# RULES "String sFromList" forall s .   sFromList (unpackCString# s) = String $ fromModified s@@ -461,18 +551,16 @@   #-}  sFromList :: [Char] -> String-sFromList l = runST (new bytes >>= copy)+sFromList l = runST (new bytes >>= startCopy)   where     -- count how many bytes     !bytes = C.foldl' (+) (Size 0) $ fmap (charToBytes . fromEnum) l -    copy :: MutableString (PrimState (ST st)) -> ST st String-    copy ms = loop azero l+    startCopy :: MutableString (PrimState (ST st)) -> ST st String+    startCopy ms = loop azero l       where         loop _   []     = freeze ms         loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs-    -- write those bytes-    --loop :: MutableByteArray# st -> Int# -> State# st -> [Char] -> (# State# st, String #) {-# INLINE [0] sFromList #-}  null :: String -> Bool@@ -482,31 +570,58 @@ -- -- if the input @s contains less characters than required, then take :: Int -> String -> String-take n s = fst $ splitAt n s -- TODO specialize+take n s@(String ba)+    | n <= 0           = mempty+    | n >= C.length ba = s+    | otherwise        = let (Offset o) = indexN n s in String $ Vec.take o ba  -- | Create a string with the remaining Chars after dropping @n Chars from the beginning drop :: Int -> String -> String drop n s@(String ba)-    | n <= 0    = s-    | otherwise = loop 0 0-  where-    !sz = C.length ba-    loop idx i-        | idx >= sz = mempty-        | i == n    = String $ C.drop idx ba-        | otherwise = loop (skipNext s idx) (i + 1)+    | n <= 0           = s+    | n >= C.length ba = mempty+    | otherwise        = let (Offset o) = indexN n s in String $ Vec.drop o ba  splitAt :: Int -> String -> (String, String)-splitAt n s@(String ba)-    | n <= 0    = (mempty, s)-    | otherwise = loop 0 0+splitAt nI s@(String ba)+    | nI <= 0           = (mempty, s)+    | nI >= C.length ba = (s, mempty)+    | otherwise =+        let (Offset k) = indexN nI s+            (v1,v2)    = C.splitAt k ba+         in (String v1, String v2)++-- | Return the offset (in bytes) of the N'th sequence in an UTF8 String+indexN :: Int -> String -> Offset Word8+indexN nI (String ba) = Vec.unsafeDewrap goVec goAddr ba   where-    !sz = C.length ba-    loop idx i-        | idx >= sz = (s, mempty)-        | i == n    = let (v1,v2) = C.splitAt idx ba in (String v1, String v2)-        | otherwise = loop (skipNext s idx) (i + 1)+    !n = Size nI+    end :: Offset Char+    !end = Offset 0 `offsetPlusE` n +    goVec :: ByteArray# -> Offset Word8 -> Offset Word8+    goVec !ma !start = loop start (Offset 0)+      where+        !len = start `offsetPlusE` Vec.lengthSize ba+        loop :: Offset Word8 -> Offset Char -> Offset Word8+        loop !idx !i+            | idx >= len || i >= end = sizeAsOffset (idx - start)+            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)+          where d = skipNextHeaderValue (primBaIndex ma idx)+    {-# INLINE goVec #-}++    goAddr :: Ptr Word8 -> Offset Word8 -> ST s (Offset Word8)+    goAddr !(Ptr ptr) !start = return $ loop start (Offset 0)+      where+        !len = start `offsetPlusE` Vec.lengthSize ba+        loop :: Offset Word8 -> Offset Char -> Offset Word8+        loop !idx !i+            | idx >= len || i >= end = sizeAsOffset (idx - start)+            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)+          where d = skipNextHeaderValue (primAddrIndex ptr idx)+    {-# INLINE goAddr #-}+{-# INLINE indexN #-}+ -- rev{Take,Drop,SplitAt} TODO optimise: -- we can process the string from the end using a skipPrev instead of getting the length @@ -573,11 +688,15 @@         {-# INLINE loop #-} {-# INLINE [2] break #-} +#if MIN_VERSION_base(4,9,0)+{-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-}+#else {-# RULES "break (== 'c')" [3] forall c . break (== c) = breakElem c #-}+#endif  breakElem :: Char -> String -> (String, String) breakElem !el s@(String ba) =-    case writeBytes el of+    case asUTF8Char el of         UTF8_1 w -> let (# v1,v2 #) = Vec.splitElem w ba in (String v1, String v2)         _        -> runST $ Vec.unsafeIndexer ba go   where@@ -596,24 +715,46 @@                     True  -> return $ splitIndex idx s                     False -> loop idx' +elem :: Char -> String -> Bool+elem !el s@(String ba) =+    case asUTF8Char el of+        UTF8_1 w -> Vec.elem w ba+        _        -> runST $ Vec.unsafeIndexer ba go+  where+    sz = size s+    end = azero `offsetPlusE` sz++    go :: (Offset Word8 -> Word8) -> ST st Bool+    go getIdx = loop (Offset 0)+      where+        !nextI = nextWithIndexer getIdx+        loop !idx+            | idx == end = return False+            | otherwise  = do+                let (c, idx') = nextI idx+                case el == c of+                    True  -> return True+                    False -> loop idx'+ intersperse :: Char -> String -> String intersperse sep src     | srcLen <= 1 = src     | otherwise   = runST $ unsafeCopyFrom src dstBytes (go sep)   where     !srcBytes = size src-    !srcLen   = length src-    dstBytes = srcBytes + ((srcLen - 1) `scale` charToBytes (fromEnum sep))+    !srcLen   = lengthSize src+    dstBytes = (srcBytes :: Size8)+             + ((srcLen - 1) `scale` charToBytes (fromEnum sep)) -    lastSrc :: Offset Char-    lastSrc = Offset 0 `offsetPlusE` Size srcLen+    lastSrcI :: Offset Char+    lastSrcI = 0 `offsetPlusE` (srcLen - 1)      go :: Char -> String -> Offset Char -> Offset8 -> MutableString s -> Offset8 -> ST s (Offset8, Offset8)     go sep' src' srcI srcIdx dst dstIdx-        | srcI == lastSrc = do+        | srcI == lastSrcI = do             nextDstIdx <- write dst dstIdx c             return (nextSrcIdx, nextDstIdx)-        | otherwise          = do+        | otherwise        = do             nextDstIdx  <- write dst dstIdx c             nextDstIdx' <- write dst nextDstIdx sep'             return (nextSrcIdx, nextDstIdx')@@ -643,16 +784,30 @@ size :: String -> Size8 size (String ba) = Size $ C.length ba -length :: String -> Int-length s@(String ba) = loop 0 0+lengthSize :: String -> Size Char+lengthSize (String ba)+    | C.null ba = Size 0+    | otherwise = Vec.unsafeDewrap goVec goAddr ba   where-    !sz     = C.length ba-    loop idx !i-        | idx == sz = i-        | otherwise =-            let idx' = skipNext s idx-             in loop idx' (i + 1)+    goVec ma start = loop start (Size 0)+      where+        !end = start `offsetPlusE` Vec.lengthSize ba+        loop !idx !i+            | idx >= end = i+            | otherwise  = loop (idx `offsetPlusE` d) (i + Size 1)+          where d = skipNextHeaderValue (primBaIndex ma idx) +    goAddr (Ptr ptr) start = return $ loop start (Size 0)+      where+        !end = start `offsetPlusE` Vec.lengthSize ba+        loop !idx !i+            | idx >= end = i+            | otherwise  = loop (idx `offsetPlusE` d) (i + Size 1)+          where d = skipNextHeaderValue (primAddrIndex ptr idx)++length :: String -> Int+length s = let (Size sz) = lengthSize s in sz+ replicate :: Int -> Char -> String replicate n c = runST (new nbBytes >>= fill)   where@@ -666,10 +821,9 @@             | idx == end = freeze ms             | otherwise  = write ms idx c >>= loop -{--sizeBytes :: String -> Int-sizeBytes (String ba) = I# (sizeofByteArray# ba)--}+-- | Copy the String+copy :: String -> String+copy (String s) = String (Vec.copy s)  -- | Allocate a MutableString of a specific size in bytes. new :: PrimMonad prim@@ -844,15 +998,6 @@                 _  -> return () -- impossible             loop ms (sidx `offsetPlusE` nb) didx' -{---- | Convert a Byte Array to a string and check UTF8 validity-fromBytes :: Encoding -> UArray Word8 -> Maybe String-fromBytes UTF8 bytes =-    case validate bytes 0 (C.length bytes) of-        (_, Nothing) -> Just $ fromBytesUnsafe bytes-        (_, Just _)  -> Nothing-        -}- data Encoding     = ASCII7     | UTF8@@ -874,7 +1019,18 @@     , mempty     ) -+-- | Convert a ByteArray to a string assuming a specific encoding.+--+-- It returns a 3-tuple of:+--+-- * The string that has been succesfully converted without any error+-- * An optional validation error+-- * The remaining buffer that hasn't been processed (either as a result of an error, or because the encoded sequence is not fully available)+--+-- Considering a stream of data that is fetched chunk by chunk, it's valid to assume+-- that some sequence might fall in a chunk boundary. When converting chunks,+-- if the error is Nothing and the remaining buffer is not empty, then this buffer+-- need to be prepended to the next chunk fromBytes :: Encoding -> UArray Word8 -> (String, Maybe ValidationFailure, UArray Word8) fromBytes ASCII7     bytes = fromEncoderBytes Encoder.ASCII7     bytes fromBytes ISO_8859_1 bytes = fromEncoderBytes Encoder.ISO_8859_1 bytes@@ -893,6 +1049,14 @@     toErr InvalidHeader       = Just InvalidHeader     toErr InvalidContinuation = Just InvalidContinuation +-- | Convert a UTF8 array of bytes to a String.+--+-- If there's any error in the stream, it will automatically+-- insert replacement bytes to replace invalid sequences.+--+-- In the case of sequence that fall in the middle of 2 chunks,+-- the remaining buffer is supposed to be preprended to the+-- next chunk, and resume the parsing. fromBytesLenient :: UArray Word8 -> (String, UArray Word8) fromBytesLenient bytes     | C.null bytes = (mempty, mempty)@@ -934,7 +1098,11 @@             (_, Just err) -> doErr err     doErr err = error ("fromChunkBytes: " <> show err) --- | Convert a Byte Array directly to a string without checking for UTF8 validity+-- | Convert a Byte Array representing UTF8 data directly to a string without checking for UTF8 validity+--+-- If the input contains invalid sequences, it will trigger runtime async errors when processing data.+--+-- In doubt, use 'fromBytes' fromBytesUnsafe :: UArray Word8 -> String fromBytesUnsafe = String @@ -947,7 +1115,11 @@                -> UArray Word8 toEncoderBytes enc bytes = Vec.recast (runST $ Encoder.convertFromTo EncoderUTF8 enc bytes) --- | Convert a String to a bytearray+-- | Convert a String to a bytearray in a specific encoding+--+-- if the encoding is UTF8, the underlying buffer is returned without extra allocation or any processing+--+-- In any other encoding, some allocation and processing are done to convert. toBytes :: Encoding -> String -> UArray Word8 toBytes UTF8       (String bytes) = bytes toBytes ASCII7     (String bytes) = toEncoderBytes Encoder.ASCII7     bytes

@@ -0,0 +1,43 @@+-- |+-- Module      : Foundation.System.Entropy+-- License     : BSD-style+-- Maintainer  : Foundation+-- Stability   : stable+-- Portability : good+--+{-# LANGUAGE CPP #-}+module Foundation.System.Entropy+    ( getEntropy+    ) where+++import           Foundation.Internal.Base+import           Foundation.Internal.Types+import qualified Foundation.Array.Unboxed.Mutable as A+import qualified Foundation.Array.Unboxed 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 :: Int -> IO (A.UArray Word8)+getEntropy n = do+    m <- A.newPinned (Size n)+    bracket entropyOpen entropyClose $ \ctx -> A.withMutablePtr m $ loop ctx n+    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 (n-chSz) (p `plusPtr` chSz)+            else throwIO EntropySystemMissing

@@ -0,0 +1,20 @@+-- |+-- Module      : Foundation.System.Entropy.Common+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Common part for vectors+--+{-# LANGUAGE DeriveDataTypeable #-}+module Foundation.System.Entropy.Common+    ( EntropySystemMissing(..)+    ) where++import Foundation.Internal.Base++data EntropySystemMissing = EntropySystemMissing+    deriving (Show,Eq,Typeable)++instance Exception EntropySystemMissing

@@ -0,0 +1,81 @@+-- |+-- Module      : Foundation.System.Entropy.Unix+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Foundation.System.Entropy.Unix+    ( EntropyCtx+    , entropyOpen+    , entropyGather+    , entropyClose+    , entropyMaximumSize+    ) where++import Foreign.Ptr+import Foreign.C.Types+import Control.Exception as E+import Control.Monad+import System.IO+import System.IO.Unsafe (unsafePerformIO)+import Foundation.Internal.Base+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

@@ -0,0 +1,102 @@+-- |+-- 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 Foundation.Internal.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

@@ -14,6 +14,7 @@       OS(..)     , os       -- * CPU info+    , Arch(..)     , arch     , cpus     , Endianness(..)

@@ -17,12 +17,15 @@     ) where  import Foundation.Internal.Base-import Data.Data+import Foundation.Class.Bifunctor  -- | Strict tuple (a,b) data Tuple2 a b = Tuple2 !a !b     deriving (Show,Eq,Ord,Typeable,Data,Generic) +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)@@ -33,66 +36,66 @@  -- | Class of product types that have a first element class Fstable a where-    type FstTy a-    fst :: a -> FstTy a+    type ProductFirst a+    fst :: a -> ProductFirst a  -- | Class of product types that have a second element class Sndable a where-    type SndTy a-    snd :: a -> SndTy a+    type ProductSecond a+    snd :: a -> ProductSecond a  -- | Class of product types that have a third element class Thdable a where-    type ThdTy a-    thd :: a -> ThdTy a+    type ProductThird a+    thd :: a -> ProductThird a  instance Fstable (a,b) where-    type FstTy (a,b) = a+    type ProductFirst (a,b) = a     fst (a,_) = a instance Fstable (a,b,c) where-    type FstTy (a,b,c) = a+    type ProductFirst (a,b,c) = a     fst (a,_,_) = a instance Fstable (a,b,c,d) where-    type FstTy (a,b,c,d) = a+    type ProductFirst (a,b,c,d) = a     fst (a,_,_,_) = a instance Fstable (Tuple2 a b) where-    type FstTy (Tuple2 a b) = a+    type ProductFirst (Tuple2 a b) = a     fst (Tuple2 a _) = a instance Fstable (Tuple3 a b c) where-    type FstTy (Tuple3 a b c) = a+    type ProductFirst (Tuple3 a b c) = a     fst (Tuple3 a _ _) = a instance Fstable (Tuple4 a b c d) where-    type FstTy (Tuple4 a b c d) = a+    type ProductFirst (Tuple4 a b c d) = a     fst (Tuple4 a _ _ _) = a  instance Sndable (a,b) where-    type SndTy (a,b) = b+    type ProductSecond (a,b) = b     snd (_,b) = b instance Sndable (a,b,c) where-    type SndTy (a,b,c) = b+    type ProductSecond (a,b,c) = b     snd (_,b,_) = b instance Sndable (a,b,c,d) where-    type SndTy (a,b,c,d) = b+    type ProductSecond (a,b,c,d) = b     snd (_,b,_,_) = b instance Sndable (Tuple2 a b) where-    type SndTy (Tuple2 a b) = b+    type ProductSecond (Tuple2 a b) = b     snd (Tuple2 _ b) = b instance Sndable (Tuple3 a b c) where-    type SndTy (Tuple3 a b c) = b+    type ProductSecond (Tuple3 a b c) = b     snd (Tuple3 _ b _) = b instance Sndable (Tuple4 a b c d) where-    type SndTy (Tuple4 a b c d) = b+    type ProductSecond (Tuple4 a b c d) = b     snd (Tuple4 _ b _ _) = b  instance Thdable (a,b,c) where-    type ThdTy (a,b,c) = c+    type ProductThird (a,b,c) = c     thd (_,_,c) = c instance Thdable (a,b,c,d) where-    type ThdTy (a,b,c,d) = c+    type ProductThird (a,b,c,d) = c     thd (_,_,c,_) = c instance Thdable (Tuple3 a b c) where-    type ThdTy (Tuple3 a b c) = c+    type ProductThird (Tuple3 a b c) = c     thd (Tuple3 _ _ c) = c instance Thdable (Tuple4 a b c d) where-    type ThdTy (Tuple4 a b c d) = c+    type ProductThird (Tuple4 a b c d) = c     thd (Tuple4 _ _ c _) = c

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

@@ -41,7 +41,6 @@ import Foundation.VFS.Path(Path(..))  import qualified Data.List-import Foundation.Partial -- ------------------------------------------------------------------------- -- --                           System related helpers                          -- -- ------------------------------------------------------------------------- --@@ -251,6 +250,6 @@  extension :: FileName -> Maybe FileName extension (FileName fn) = case splitOn (\c -> c == 0x2E) fn of-                            [] -> Nothing+                            []  -> Nothing                             [_] -> Nothing-                            xs -> Just $ FileName $ fromPartial $ head $ reverse xs+                            xs  -> Just $ FileName $ last $ nonEmpty_ xs

@@ -21,6 +21,11 @@  import Foundation.Internal.Base +-- $setup+-- >>> import Foundation.Internal.Base+-- >>> import Foundation.VFS.FilePath+-- >>> import Foundation.VFS.Path+ -- | Path type class -- -- defines the Path associated types and basic functions to implement related@@ -28,12 +33,12 @@ -- -- # 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--- ```+-- @+-- 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`@@ -44,14 +49,14 @@      -- | the associated prefix of the given `path`     ---    -- in the case of a `FilePath`, it is a void (i.e. `()`)-    -- in the case of an `URI`, it is the schema, host, port...+    -- 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 `FilePath`, it is a void (i.e. `()`)-    -- in the case of the `URI`, it is a the query, the fragment+    -- 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@@ -62,6 +67,7 @@                          , [PathEnt path]                          , PathSuffix path                          )+     -- | build the path from the associated elements     buildPath :: ( PathPrefix path                  , [PathEnt path]@@ -74,18 +80,30 @@ -- -- 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+    (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+-- 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@@ -108,16 +126,18 @@  -- | get the path prefix information ----- ```--- prefix "/home/tab" == ()--- ```+-- >>> 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@@ -125,16 +145,15 @@  -- | get the path suffix information ----- ```--- suffix "/home/tab" == ()--- ```+-- >>> 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

@@ -2,6 +2,7 @@ ==========  [![Build Status](https://travis-ci.org/haskell-foundation/foundation.png?branch=master)](https://travis-ci.org/haskell-foundation/foundation)+[![Coverage Status](https://coveralls.io/repos/github/haskell-foundation/foundation/badge.svg?branch=master)](https://coveralls.io/github/haskell-foundation/foundation?branch=master) [![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) [![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) @@ -16,9 +17,27 @@ * provide better data-types: packed unicode string by default, arrays. * Better numerical classes that better represent mathematical things (No more all-in-one Num). -How to use-==========+Usage+===== +How to use with the normal Prelude+----------------------------------++Add the `foundation` package in your cabal file, and it's recommended to import Foundation qualified if+you're planning to use with the normal Prelude:++For example:++```haskell+import qualified Foundation as F+```++It's also recommended if you're going to deal with packages using text, bytestring, vector.. to use+the `foundation-edge` package.++How to use fully without Prelude+--------------------------------+ Disable the built-in prelude at the top of your file:  ```haskell@@ -37,6 +56,13 @@ import Foundation ``` +Advanced settings+----------------------++Please check out the chapter [Advanced Usage Options](docs/Advanced.md) in the+documentation.++ How to contribute ================= @@ -49,7 +75,50 @@ * Make tutorial on how to use foundation * Make your project use foundation instead of base, report the missing coverage (IO, types, etc.), or what functionality is missing to make a succesful transition +Profiling+--------- +If you want to see the core (simpl step) or the assembly (asm step), then you can build with++    stack build --ghc-options -ddump-simpl --ghc-options -ddump-asm++Note that it doesn't actually will create the necessary extra files if the modules doesn't need building.++you can then find your build by-products in:++    .stack-work/dist/<architecture>/Cabal-<CabalVersion>/build/++Each modules that get compiled will create an equivalent file in the build directory:++* ModuleName.dump-simpl+* ModuleName.dump-asm++For profiling individual programs, the following command is useful:++    stack ghc -- -O --make X.hs -prof -auto-all -caf-all -fforce-recomp++Benchmarking+------------++To get the list of benchmark:++    stack bench --benchmark-arguments -l++To compare against other libraries, you need to set the `bench-all` flag++    stack bench --flag foundation:bench-all --benchmark-arguments -l++To run a specific or set of benchmarks :++    stack bench --flag foundation:bench-all --benchmark-arguments 'types/String/SplitAt/mascii-10/Text'+    stack bench --flag foundation:bench-all --benchmark-arguments '-m prefix types/String/SplitAt'+    stack bench --flag foundation:bench-all --benchmark-arguments '-m glob types/String/SplitAt'++To register a set of benchmarks:++    stack bench --flag foundation:bench-all --benchmark-arguments "--csv $(git describe).csv"++ Design ====== @@ -57,9 +126,9 @@ simple and consistent package. The amazing haskell ecosystem is extremely fragmented and maintained by different people with different goals, free time, and style. The overall scare of not trying to change anything relatively-central (base, bytestring, text, vector ..) for a promise of stability has pushed-many people to work on their own thing, leading to unnecessary work duplication-and further fragmentation.+central (`base`, `bytestring`, `text`, `vector`, ...) for a promise of stability+has pushed many people to work on their own thing, leading to unnecessary work+duplication and further fragmentation.   Foundation uses and abuses type families.

@@ -1,16 +0,0 @@-module Main where--import Foundation-import Foundation.Collection-import Criterion.Main--main = defaultMain-    [ bgroup "Uarray"-        [ bench "fromList [Word8]" $ whnf (fromList :: [Word8] -> UArray Word8) [1..255]-        , bench "fromList [Word16]" $ whnf (fromList :: [Word16] -> UArray Word16) [1..1024]-        , bench "break" $ whnf (break (== 255)) input-        ]-    ]-  where-    input :: UArray Word8-    input = fromList ([1..255] <> [1..255])

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+module BenchUtil.Common+    ( defaultMain+    , Benchmark+    , Benchmarkable+    , bgroup+    , bench+    , fbench+    , whnf+    , whnfIO+    , nf+    ) where++import           Criterion.Main hiding (bgroup, bench)+import qualified Criterion.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

@@ -0,0 +1,44 @@+module BenchUtil.RefData+    (+    -- string+      rdLoremIpsum1+    , rdLoremIpsum5+    , rdFoundationEn+    , rdFoundationZh+    , rdFoundationJap+    , rdFoundationHun+    -- byte array+    , rdBytes20+    , rdBytes200+    , rdBytes2000+    ) where++import Prelude (Char, cycle, take, ($))+import Data.Word (Word8)++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."++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) を編纂するグループ「ファウンデーション」をつくったが、帝国崩壊を公言し平和を乱したという罪で裁判にかけられ、グループは銀河系辺縁部にある資源の乏しい無人惑星ターミナスへ追放されることになった。しかし、この追放劇すらもセルダンの計画に予定されていた事柄であった。病で死期をさとっていたセルダンは、己の仕事が終わったことを確信する。"++rdBytes20 ::[Word8]+rdBytes20 = take 20 $ cycle [1..255]++rdBytes200 :: [Word8]+rdBytes200 = take 200 $ cycle [1..255]++rdBytes2000 :: [Word8]+rdBytes2000 = take 2000 $ cycle [1..255]