basement 0.0.2 → 0.0.3

raw patch · 25 files changed

+1141/−390 lines, 25 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Basement/Alg/Foreign/Prim.hs +0/−0
• Basement/Alg/Foreign/PrimArray.hs +0/−55
• Basement/Alg/Mutable.hs +74/−0
• Basement/Alg/Native/PrimArray.hs +0/−55
• Basement/Base16.hs +12/−0
• Basement/Block.hs +10/−1
• Basement/Block/Base.hs +28/−7
• Basement/Block/Mutable.hs +1/−26
• Basement/BlockN.hs +2/−148
• Basement/BoxedArray.hs +12/−31
• Basement/Compat/ExtList.hs +10/−3
• Basement/Compat/Semigroup.hs +160/−0
• Basement/Floating.hs +44/−0
• Basement/From.hs +1/−1
• Basement/Nat.hs +5/−2
• Basement/Sized/Block.hs +156/−0
• Basement/Sized/List.hs +234/−0
• Basement/Sized/UVect.hs +159/−0
• Basement/Sized/Vect.hs +161/−0
• Basement/String.hs +9/−9
• Basement/UArray.hs +34/−26
• Basement/UArray/Base.hs +9/−15
• Basement/UArray/Mutable.hs +3/−3
• Basement/UTF8/Base.hs +7/−7
• basement.cabal +10/−1

@@ -15,7 +15,6 @@     , any     , filter     , primIndex-    , inplaceSortBy     ) where  import           GHC.Types@@ -123,57 +122,3 @@         | predicate (primIndex ba i) = True         | otherwise                  = loop (i+1) {-# INLINE any #-}--inplaceSortBy :: (PrimType ty, PrimMonad prim)-              => (ty -> ty -> Ordering)-              -> Mutable (PrimState prim)-              -> Offset ty-              -> Offset ty-              -> prim ()-inplaceSortBy ford ma start end = qsort start (end `offsetSub` 1)-  where-    qsort lo hi-        | lo >= hi  = pure ()-        | otherwise = do-            p <- partition lo hi-            qsort lo (pred p)-            qsort (p+1) hi-    pivotStrategy (Offset low) hi@(Offset high) = do-        let mid = Offset $ (low + high) `div` 2-        pivot <- primRead ma mid-        primRead ma hi >>= primWrite ma mid-        primWrite ma hi pivot -- move pivot @ pivotpos := hi-        pure pivot-    partition lo hi = do-        pivot <- pivotStrategy lo hi-        -- RETURN: index of pivot with [<pivot | pivot | >=pivot]-        -- INVARIANT: i & j are valid array indices; pivotpos==hi-        let go i j = do-                -- INVARIANT: k <= pivotpos-                let fw k = do ak <- primRead ma k-                              if ford ak pivot == LT-                                then fw (k+1)-                                else pure (k, ak)-                (i, ai) <- fw i -- POST: ai >= pivot-                -- INVARIANT: k >= i-                let bw k | k==i = pure (i, ai)-                         | otherwise = do ak <- primRead ma k-                                          if ford ak pivot /= LT-                                            then bw (pred k)-                                            else pure (k, ak)-                (j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)-                -- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))-                if i < j-                    then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)-                        -- swap two non-pivot elements and proceed-                        primWrite ma i aj-                        primWrite ma j ai-                        -- POST: (ai < pivot <= aj)-                        go (i+1) (pred j)-                    else do -- ai >= pivot-                        -- complete partitioning by swapping pivot to the center-                        primWrite ma hi ai-                        primWrite ma i pivot-                        pure i-        go lo hi-{-# INLINE inplaceSortBy #-}

@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Basement.Alg.Mutable+    ( RandomAccess, read, write+    , inplaceSortBy+    ) where++import           GHC.Types+import           GHC.Prim+import           Basement.Compat.Base+import           Basement.Numerical.Additive+import           Basement.Numerical.Multiplicative+import           Basement.Types.OffsetSize+import           Basement.PrimType+import           Basement.Monad++class RandomAccess container prim ty where+    read  :: container -> (Offset ty)       -> prim ty+    write :: container -> (Offset ty) -> ty -> prim ()++inplaceSortBy :: (PrimMonad prim, RandomAccess container prim ty) +              => (ty -> ty -> Ordering)+              -- ^ Function defining the ordering relationship+              -> (Offset ty) -- ^ Offset to first element to sort+              -> (CountOf ty) -- ^ Number of elements to sort+              -> container -- ^ Data to be sorted+              -> prim ()+inplaceSortBy ford start len mvec+    = qsort start (start `offsetPlusE` len `offsetSub` 1)+    where+        qsort lo hi+            | lo >= hi  = pure ()+            | otherwise = do+                p <- partition lo hi+                qsort lo (pred p)+                qsort (p+1) hi+        pivotStrategy (Offset low) hi@(Offset high) = do+            let mid = Offset $ (low + high) `div` 2+            pivot <- read mvec mid+            read mvec hi >>= write mvec mid+            write mvec hi pivot -- move pivot @ pivotpos := hi+            pure pivot+        partition lo hi = do+            pivot <- pivotStrategy lo hi+            -- RETURN: index of pivot with [<pivot | pivot | >=pivot]+            -- INVARIANT: i & j are valid array indices; pivotpos==hi+            let go i j = do+                    -- INVARIANT: k <= pivotpos+                    let fw k = do ak <- read mvec k+                                  if ford ak pivot == LT +                                    then fw (k+1)+                                    else pure (k, ak)+                    (i, ai) <- fw i -- POST: ai >= pivot+                    -- INVARIANT: k >= i+                    let bw k | k==i = pure (i, ai)+                             | otherwise = do ak <- read mvec k+                                              if ford ak pivot /= LT+                                                then bw (pred k)+                                                else pure (k, ak)+                    (j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)+                    -- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))+                    if i < j+                        then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)+                            -- swap two non-pivot elements and proceed+                            write mvec i aj+                            write mvec j ai+                            -- POST: (ai < pivot <= aj)+                            go (i+1) (pred j)+                        else do -- ai >= pivot +                            -- complete partitioning by swapping pivot to the center+                            write mvec hi ai +                            write mvec i pivot+                            pure i+            go lo hi+{-# INLINE inplaceSortBy #-}

@@ -15,7 +15,6 @@     , any     , filter     , primIndex-    , inplaceSortBy     ) where  import           GHC.Types@@ -123,57 +122,3 @@         | predicate (primIndex ba i) = True         | otherwise                  = loop (i+1) {-# INLINE any #-}--inplaceSortBy :: (PrimType ty, PrimMonad prim)-              => (ty -> ty -> Ordering)-              -> Mutable (PrimState prim)-              -> Offset ty-              -> Offset ty-              -> prim ()-inplaceSortBy ford ma start end = qsort start (end `offsetSub` 1)-  where-    qsort lo hi-        | lo >= hi  = pure ()-        | otherwise = do-            p <- partition lo hi-            qsort lo (pred p)-            qsort (p+1) hi-    pivotStrategy (Offset low) hi@(Offset high) = do-        let mid = Offset $ (low + high) `div` 2-        pivot <- primRead ma mid-        primRead ma hi >>= primWrite ma mid-        primWrite ma hi pivot -- move pivot @ pivotpos := hi-        pure pivot-    partition lo hi = do-        pivot <- pivotStrategy lo hi-        -- RETURN: index of pivot with [<pivot | pivot | >=pivot]-        -- INVARIANT: i & j are valid array indices; pivotpos==hi-        let go i j = do-                -- INVARIANT: k <= pivotpos-                let fw k = do ak <- primRead ma k-                              if ford ak pivot == LT-                                then fw (k+1)-                                else pure (k, ak)-                (i, ai) <- fw i -- POST: ai >= pivot-                -- INVARIANT: k >= i-                let bw k | k==i = pure (i, ai)-                         | otherwise = do ak <- primRead ma k-                                          if ford ak pivot /= LT-                                            then bw (pred k)-                                            else pure (k, ak)-                (j, aj) <- bw j -- POST: i==j OR (aj<pivot AND j<pivotpos)-                -- POST: ai>=pivot AND (i==j OR aj<pivot AND (j<pivotpos))-                if i < j-                    then do -- (ai>=p AND aj<p) AND (i<j<pivotpos)-                        -- swap two non-pivot elements and proceed-                        primWrite ma i aj-                        primWrite ma j ai-                        -- POST: (ai < pivot <= aj)-                        go (i+1) (pred j)-                    else do -- ai >= pivot-                        -- complete partitioning by swapping pivot to the center-                        primWrite ma hi ai-                        primWrite ma i pivot-                        pure i-        go lo hi-{-# INLINE inplaceSortBy #-}

@@ -5,12 +5,17 @@     ( unsafeConvertByte     , hexWord16     , hexWord32+    , escapeByte+    , Base16Escape(..)     ) where  import GHC.Prim import GHC.Types import GHC.Word+import Basement.Types.Char7 +data Base16Escape = Base16Escape {-# UNPACK #-} !Char7 {-# UNPACK #-} !Char7+ -- | Convert a byte value in Word# to two Word#s containing -- the hexadecimal representation of the Word# --@@ -24,6 +29,13 @@     r :: Table -> Word# -> Word#     r (Table !table) index = indexWord8OffAddr# table (word2Int# index) {-# INLINE unsafeConvertByte #-}++escapeByte :: Word8 -> Base16Escape+escapeByte !(W8# b) = Base16Escape (r tableHi b) (r tableLo b)+  where+    r :: Table -> Word# -> Char7+    r (Table !table) index = Char7 (W8# (indexWord8OffAddr# table (word2Int# index)))+{-# INLINE escapeByte #-}  -- | hex word16 hexWord16 :: Word16 -> (Char, Char, Char, Char)

@@ -14,6 +14,8 @@ {-# LANGUAGE MagicHash           #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Basement.Block     ( Block(..)     , MutableBlock(..)@@ -79,7 +81,14 @@ import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive import qualified Basement.Alg.Native.PrimArray as Alg+import qualified Basement.Alg.Native.Prim as Prim+import qualified Basement.Alg.Mutable as MutAlg +instance (PrimMonad prim, st ~ PrimState prim, PrimType ty) +         => MutAlg.RandomAccess (MutableBlock ty st) prim ty where+    read (MutableBlock mba) = primMbaRead mba+    write (MutableBlock mba) = primMbaWrite mba+ -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim                 => Block ty -- ^ the source block to copy@@ -355,7 +364,7 @@     | len == 0  = mempty     | otherwise = runST $ do         mblock@(MutableBlock mba) <- thaw vec-        Alg.inplaceSortBy ford mba 0 (sizeAsOffset len)+        MutAlg.inplaceSortBy ford 0 len mblock         unsafeFreeze mblock   where len = length vec {-# SPECIALIZE [2] sortBy :: (Word8 -> Word8 -> Ordering) -> Block Word8 -> Block Word8 #-}

@@ -22,8 +22,8 @@     , mutableEmpty     , new     , newPinned-    , touch-    , mutableTouch+    , withPtr+    , mutableWithPtr     ) where  import           GHC.Prim@@ -334,9 +334,30 @@ unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v {-# INLINE unsafeWrite #-} -touch :: PrimMonad prim => Block ty -> prim ()-touch (Block ba) = unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }--mutableTouch :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim ()-mutableTouch (MutableBlock mba) = unsafePrimFromIO $ primitive $ \s -> case touch# mba s of { s2 -> (# s2, () #) }+-- | Use the 'Ptr' to a block in a safer construct+--+-- If the block is not pinned, this is a _dangerous_ operation+withPtr :: PrimMonad prim+        => Block ty+        -> (Ptr ty -> prim a)+        -> prim a+withPtr (Block ba) f = do+    let addr = Ptr (byteArrayContents# ba)+    res <- f addr+    unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }+    return res +-- | Use the 'Ptr' to a mutable block in a safer construct+--+-- If the block is not pinned, this is a _dangerous_ operation+mutableWithPtr :: PrimMonad prim+                => MutableBlock ty (PrimState prim)+                -> (Ptr ty -> prim a)+                -> prim a+mutableWithPtr (MutableBlock mba) f = do+    addr <- primitive $ \s1 ->+        case unsafeFreezeByteArray# mba s1 of+            (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)+    res <- f addr+    unsafePrimFromIO $ primitive $ \s -> case touch# mba s of { s2 -> (# s2, () #) }+    return res

@@ -39,9 +39,7 @@     , MutableBlock(..)     , mutableLengthSize     , mutableLengthBytes-    , mutableGetAddr-    , mutableWithAddr-    , mutableTouch+    , mutableWithPtr     , new     , newPinned     , mutableEmpty@@ -83,29 +81,6 @@ mutableLengthBytes :: MutableBlock ty st -> CountOf Word8 mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba)) {-# INLINE[1] mutableLengthBytes #-}---- | Get the address of the context of the mutable block.------ if the block is not pinned, this is a _dangerous_ operation------ Note that if nothing is holding the block, the GC can garbage collect the block--- and thus the address is dangling on the memory. use 'mutableWithAddr' to prevent--- this problem by construction-mutableGetAddr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Ptr ty)-mutableGetAddr (MutableBlock mba) = primitive $ \s1 ->-    case unsafeFreezeByteArray# mba s1 of-        (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #)---- | Get the address of the mutable block in a safer construct------ if the block is not pinned, this is a _dangerous_ operation-mutableWithAddr :: PrimMonad prim-                => MutableBlock ty (PrimState prim)-                -> (Ptr ty -> prim a)-                -> prim a-mutableWithAddr mb f = do-    addr <- mutableGetAddr mb-    f addr <* mutableTouch mb  -- | Set all mutable block element to a value iterSet :: (PrimType ty, PrimMonad prim)

@@ -4,153 +4,7 @@ -- Maintainer  : Haskell Foundation -- -- A Nat-sized version of Block-{-# LANGUAGE AllowAmbiguousTypes        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ConstraintKinds            #-} -module Basement.BlockN-    ( BlockN-    , MutableBlockN-    , toBlockN-    , toBlock-    , singleton-    , replicate-    , thaw-    , freeze-    , index-    , map-    , foldl'-    , foldr-    , cons-    , snoc-    , elem-    , sub-    , uncons-    , unsnoc-    , splitAt-    , all-    , any-    , find-    , reverse-    , sortBy-    , intersperse-    )-where--import           Data.Proxy (Proxy(..))-import           Basement.Compat.Base-import           Basement.Block (Block, MutableBlock(..), unsafeIndex)-import qualified Basement.Block as B-import           Basement.Monad (PrimMonad, PrimState)-import           Basement.Nat-import           Basement.NormalForm-import           Basement.PrimType (PrimType)-import           Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub)--newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show)--newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st }--toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => Block ty -> Maybe (BlockN n ty)-toBlockN b-    | expected == B.length b = Just (BlockN b)-    | otherwise = Nothing-  where-    expected = toCount @n--toBlock :: BlockN n ty -> Block ty-toBlock = unBlock--singleton :: PrimType ty => ty -> BlockN 1 ty-singleton a = BlockN (B.singleton a)--replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> BlockN n ty-replicate a = BlockN (B.replicate (toCount @n) a)--thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim))-thaw b = MutableBlockN <$> B.thaw (unBlock b)--freeze ::  (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty)-freeze b = BlockN <$> B.freeze (unMBlock b)--index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty-index b = unsafeIndex (unBlock b) (toOffset @i)--map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b-map f b = BlockN (B.map f (unBlock b))--foldl' :: PrimType ty => (a -> ty -> a) -> a -> BlockN n ty -> a-foldl' f acc b = B.foldl' f acc (unBlock b)--foldr :: PrimType ty => (ty -> a -> a) -> a -> BlockN n ty -> a-foldr f acc b = B.foldr f acc (unBlock b)--cons :: PrimType ty => ty -> BlockN n ty -> BlockN (n+1) ty-cons e = BlockN . B.cons e . unBlock--snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty-snoc b = BlockN . B.snoc (unBlock b)--sub :: forall i j n ty-     . ( (i <=? n) ~ 'True-       , (j <=? n) ~ 'True-       , (i <=? j) ~ 'True-       , PrimType ty-       , KnownNat i-       , KnownNat j-       , Offsetable ty i-       , Offsetable ty j )-    => BlockN n ty-    -> BlockN (j-i) ty-sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j))--uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n)-       => BlockN n ty-       -> (ty, BlockN (n-1) ty)-uncons b = (index @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n)))--unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n)-       => BlockN n ty-       -> (BlockN (n-1) ty, ty)-unsnoc b =-    ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1))-    , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1))--splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty)-splitAt b =-    let (left, right) = B.splitAt (toCount @i) (unBlock b)-     in (BlockN left, BlockN right)--elem :: PrimType ty => ty -> BlockN n ty -> Bool-elem e b = B.elem e (unBlock b)--all :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool-all p b = B.all p (unBlock b)--any :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool-any p b = B.any p (unBlock b)--find :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Maybe ty-find p b = B.find p (unBlock b)--reverse :: PrimType ty => BlockN n ty -> BlockN n ty-reverse = BlockN . B.reverse . unBlock--sortBy :: PrimType ty => (ty -> ty -> Ordering) -> BlockN n ty -> BlockN n ty-sortBy f b = BlockN (B.sortBy f (unBlock b))--intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty-intersperse sep b = BlockN (B.intersperse sep (unBlock b))--toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty-toCount = natValCountOf (Proxy @n)--toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty-toOffset = natValOffset (Proxy @n)+module Basement.BlockN (module X) where -type Countable ty n = NatWithinBound (CountOf ty) n-type Offsetable ty n = NatWithinBound (Offset ty) n+import Basement.Sized.Block as X

@@ -11,6 +11,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Basement.BoxedArray     ( Array     , MArray@@ -21,6 +23,7 @@     , unsafeCopyAtRO     , thaw     , new+    , create     , unsafeFreeze     , unsafeThaw     , freeze@@ -79,6 +82,7 @@ import           Basement.Numerical.Subtractive import           Basement.NonEmpty import           Basement.Compat.Base+import qualified Basement.Alg.Mutable as MutAlg import           Basement.Compat.MonadTrans import           Basement.Types.OffsetSize import           Basement.PrimType@@ -250,7 +254,7 @@        -> Offset ty                  -- ^ offset at destination        -> MArray ty (PrimState prim) -- ^ source array        -> Offset ty                  -- ^ offset at source-       -> CountOf ty                    -- ^ number of elements to copy+       -> CountOf ty                 -- ^ number of elements to copy        -> prim () copyAt dst od src os n = loop od os   where -- !endIndex = os `offsetPlusE` n@@ -352,7 +356,7 @@ vFromList :: [a] -> Array a vFromList l = runST (new len >>= loop 0 l)   where-    len = CountOf $ List.length l+    len = List.length l     loop _ []     ma = unsafeFreeze ma     loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma @@ -623,6 +627,11 @@             let e = unsafeIndex vec i              in if predicate e then Just e else loop (i+1) +instance (PrimMonad prim, st ~ PrimState prim) +         => MutAlg.RandomAccess (MArray ty st) prim ty where+    read (MArray _ _ mba) = primMutableArrayRead mba+    write (MArray _ _ mba) = primMutableArrayWrite mba+ sortBy :: forall ty . (ty -> ty -> Ordering) -> Array ty -> Array ty sortBy xford vec     | len == 0  = empty@@ -630,35 +639,7 @@   where     len = length vec     doSort :: PrimMonad prim => (ty -> ty -> Ordering) -> MArray ty (PrimState prim) -> prim (Array ty)-    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma-      where-        qsort lo hi-            | lo >= hi  = pure ()-            | otherwise = do-                p <- partition lo hi-                qsort lo (pred p)-                qsort (p+1) hi-        partition lo hi = do-            pivot <- unsafeRead ma hi-            let loop i j-                    | j == hi   = pure i-                    | otherwise = do-                        aj <- unsafeRead ma j-                        i' <- if ford aj pivot == GT-                                then pure i-                                else do-                                    ai <- unsafeRead ma i-                                    unsafeWrite ma j ai-                                    unsafeWrite ma i aj-                                    pure $ i + 1-                        loop i' (j+1)--            i <- loop lo lo-            ai  <- unsafeRead ma i-            ahi <- unsafeRead ma hi-            unsafeWrite ma hi ai-            unsafeWrite ma i ahi-            pure i+    doSort ford ma = MutAlg.inplaceSortBy ford 0 len ma >> unsafeFreeze ma  filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec))

@@ -4,18 +4,20 @@     , null     , sum     , reverse+    , (!!)     ) where  import Basement.Compat.Base import Basement.Numerical.Additive+import Basement.Types.OffsetSize import qualified GHC.List as List  -- | Compute the size of the list-length :: [a] -> Int+length :: [a] -> CountOf a #if MIN_VERSION_base(4,8,0)-length = List.foldl' (\c _ -> c+1) 0+length = CountOf . List.foldl' (\c _ -> c+1) 0 #else-length = loop 0+length = CountOf . loop 0   where loop !acc []     = acc         loop !acc (_:xs) = loop (1+acc) xs #endif@@ -38,3 +40,8 @@   where     go []     acc = acc     go (x:xs) acc = go xs (x:acc)++(!!) :: [a] -> Offset a -> a+[]    !! _  = error "invalid offset for !!"+(x:_) !! 0  = x+(_:xs) !! i = xs !! pred i

@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+#if !(MIN_VERSION_base(4,9,0))+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+#endif+module Basement.Compat.Semigroup+    ( Semigroup(..)+    , ListNonEmpty(..)+    ) where++#if MIN_VERSION_base(4,9,0)+import           Data.Semigroup+import qualified Data.List.NonEmpty as LNE++type ListNonEmpty = LNE.NonEmpty+#else+import Prelude+import Data.Data (Data)+import Data.Monoid (Monoid(..))+import GHC.Generics (Generic)++-- errorWithoutStackTrace++infixr 6 <>+infixr 5 :|++data ListNonEmpty a = a :| [a]+  deriving ( Eq, Ord, Show, Read, Data, Generic )++-- | The class of semigroups (types with an associative binary operation).+--+-- @since 4.9.0.0+class Semigroup a where+  -- | An associative operation.+  --+  -- @+  -- (a '<>' b) '<>' c = a '<>' (b '<>' c)+  -- @+  --+  -- If @a@ is also a 'Monoid' we further require+  --+  -- @+  -- ('<>') = 'mappend'+  -- @+  (<>) :: a -> a -> a++  default (<>) :: Monoid a => a -> a -> a+  (<>) = mappend++  -- | Reduce a non-empty list with @\<\>@+  --+  -- The default definition should be sufficient, but this can be+  -- overridden for efficiency.+  --+  sconcat :: ListNonEmpty a -> a+  sconcat (a :| as) = go a as where+    go b (c:cs) = b <> go c cs+    go b []     = b++  -- | Repeat a value @n@ times.+  --+  -- Given that this works on a 'Semigroup' it is allowed to fail if+  -- you request 0 or fewer repetitions, and the default definition+  -- will do so.+  --+  -- By making this a member of the class, idempotent semigroups and monoids can+  -- upgrade this to execute in /O(1)/ by picking+  -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@+  -- respectively.+  stimes :: Integral b => b -> a -> a+  stimes y0 x0+    | y0 <= 0   = errorWithoutStackTrace "stimes: positive multiplier expected"+    | otherwise = f x0 y0+    where+      f x y+        | even y = f (x <> x) (y `quot` 2)+        | y == 1 = x+        | otherwise = g (x <> x) (pred y  `quot` 2) x+      g x y z+        | even y = g (x <> x) (y `quot` 2) z+        | y == 1 = x <> z+        | otherwise = g (x <> x) (pred y `quot` 2) (x <> z)++instance Semigroup a => Semigroup (Maybe a) where+  Nothing <> b       = b+  a       <> Nothing = a+  Just a  <> Just b  = Just (a <> b)+  stimes _ Nothing  = Nothing+  stimes n (Just a) = case compare n 0 of+    LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"+    EQ -> Nothing+    GT -> Just (stimes n a)++instance Semigroup (Either a b) where+  Left _ <> b = b+  a      <> _ = a+  stimes = stimesIdempotent++instance (Semigroup a, Semigroup b) => Semigroup (a, b) where+  (a,b) <> (a',b') = (a<>a',b<>b')+  stimes n (a,b) = (stimes n a, stimes n b)++instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where+  (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')+  stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)++instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)+         => Semigroup (a, b, c, d) where+  (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')+  stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)++instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)+         => Semigroup (a, b, c, d, e) where+  (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')+  stimes n (a,b,c,d,e) =+      (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)++-- | This is a valid definition of 'stimes' for a 'Monoid'.+--+-- Unlike the default definition of 'stimes', it is defined for 0+-- and so it should be preferred where possible.+stimesMonoid :: (Integral b, Monoid a) => b -> a -> a+stimesMonoid n x0 = case compare n 0 of+  LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"+  EQ -> mempty+  GT -> f x0 n+    where+      f x y+        | even y = f (x `mappend` x) (y `quot` 2)+        | y == 1 = x+        | otherwise = g (x `mappend` x) (pred y  `quot` 2) x+      g x y z+        | even y = g (x `mappend` x) (y `quot` 2) z+        | y == 1 = x `mappend` z+        | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z)++-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.+--+-- When @mappend x x = x@, this definition should be preferred, because it+-- works in /O(1)/ rather than /O(log n)/+stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a+stimesIdempotentMonoid n x = case compare n 0 of+  LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"+  EQ -> mempty+  GT -> x++-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.+--+-- When @x <> x = x@, this definition should be preferred, because it+-- works in /O(1)/ rather than /O(log n)/.+stimesIdempotent :: Integral b => b -> a -> a+stimesIdempotent n x+  | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"+  | otherwise = x++#if !MIN_VERSION_base(4,9,0)+errorWithoutStackTrace = error+#endif++#endif

@@ -1,12 +1,24 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-} module Basement.Floating     ( integerToDouble     , naturalToDouble     , doubleExponant     , integerToFloat     , naturalToFloat+    , wordToFloat+    , floatToWord+    , wordToDouble+    , doubleToWord     ) where  import           GHC.Types+import           GHC.Prim+import           GHC.Float+import           GHC.Word+import           GHC.ST import           Basement.Compat.Base import           Basement.Compat.Natural import qualified Prelude (fromInteger, toInteger, (^^))@@ -27,3 +39,35 @@  naturalToFloat :: Natural -> Float naturalToFloat = integerToFloat . Prelude.toInteger++wordToFloat :: Word32 -> Float+wordToFloat (W32# x) = runST $ ST $ \s1 ->+    case newByteArray# 4# s1             of { (# s2, mbarr #) ->+    case writeWord32Array# mbarr 0# x s2 of { s3              ->+    case readFloatArray# mbarr 0# s3     of { (# s4, f #)     ->+        (# s4, F# f #) }}}+{-# INLINE wordToFloat #-}++floatToWord :: Float -> Word32+floatToWord (F# x) = runST $ ST $ \s1 ->+    case newByteArray# 4# s1            of { (# s2, mbarr #) ->+    case writeFloatArray# mbarr 0# x s2 of { s3              ->+    case readWord32Array# mbarr 0# s3   of { (# s4, w #)     ->+        (# s4, W32# w #) }}}+{-# INLINE floatToWord #-}++wordToDouble :: Word64 -> Double+wordToDouble (W64# x) = runST $ ST $ \s1 ->+    case newByteArray# 8# s1             of { (# s2, mbarr #) ->+    case writeWord64Array# mbarr 0# x s2 of { s3              ->+    case readDoubleArray# mbarr 0# s3    of { (# s4, f #)     ->+        (# s4, D# f #) }}}+{-# INLINE wordToDouble #-}++doubleToWord :: Double -> Word64+doubleToWord (D# x) = runST $ ST $ \s1 ->+    case newByteArray# 8# s1             of { (# s2, mbarr #) ->+    case writeDoubleArray# mbarr 0# x s2 of { s3              ->+    case readWord64Array# mbarr 0# s3    of { (# s4, w #)     ->+        (# s4, W64# w #) }}}+{-# INLINE doubleToWord #-}

@@ -57,7 +57,7 @@ -- nat instances #if __GLASGOW_HASKELL__ >= 800 import           Basement.Nat-import qualified Basement.BlockN as BlockN+import qualified Basement.Sized.Block as BlockN import           Basement.Bounded #endif 

@@ -7,9 +7,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE UndecidableInstances      #-}-#if __GLASGOW_HASKELL__ < 800 {-# LANGUAGE ConstraintKinds           #-}-#endif module Basement.Nat     ( Nat     , KnownNat@@ -35,6 +33,8 @@     -- * Constraint     , NatInBoundOf     , NatWithinBound+    , Countable+    , Offsetable     ) where  #include "MachDeps.h"@@ -134,3 +134,6 @@ #else type NatWithinBound ty n = NatInBoundOf ty n ~ 'True #endif++type Countable ty n = NatWithinBound (CountOf ty) n+type Offsetable ty n = NatWithinBound (Offset ty) n

@@ -0,0 +1,156 @@+-- |+-- Module      : Basement.Sized.Block+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- A Nat-sized version of Block+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds            #-}++module Basement.Sized.Block+    ( BlockN+    , MutableBlockN+    , toBlockN+    , toBlock+    , singleton+    , replicate+    , thaw+    , freeze+    , index+    , indexStatic+    , map+    , foldl'+    , foldr+    , cons+    , snoc+    , elem+    , sub+    , uncons+    , unsnoc+    , splitAt+    , all+    , any+    , find+    , reverse+    , sortBy+    , intersperse+    ) where++import           Data.Proxy (Proxy(..))+import           Basement.Compat.Base+import           Basement.Block (Block, MutableBlock(..), unsafeIndex)+import qualified Basement.Block as B+import           Basement.Monad (PrimMonad, PrimState)+import           Basement.Nat+import           Basement.NormalForm+import           Basement.PrimType (PrimType)+import           Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub)++newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show)++newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st }++toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => Block ty -> Maybe (BlockN n ty)+toBlockN b+    | expected == B.length b = Just (BlockN b)+    | otherwise = Nothing+  where+    expected = toCount @n++toBlock :: BlockN n ty -> Block ty+toBlock = unBlock++singleton :: PrimType ty => ty -> BlockN 1 ty+singleton a = BlockN (B.singleton a)++replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> BlockN n ty+replicate a = BlockN (B.replicate (toCount @n) a)++thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim))+thaw b = MutableBlockN <$> B.thaw (unBlock b)++freeze ::  (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty)+freeze b = BlockN <$> B.freeze (unMBlock b)++indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty+indexStatic b = unsafeIndex (unBlock b) (toOffset @i)++index :: forall i n ty . PrimType ty => BlockN n ty -> Offset ty -> ty+index b ofs = B.index (unBlock b) ofs++map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b+map f b = BlockN (B.map f (unBlock b))++foldl' :: PrimType ty => (a -> ty -> a) -> a -> BlockN n ty -> a+foldl' f acc b = B.foldl' f acc (unBlock b)++foldr :: PrimType ty => (ty -> a -> a) -> a -> BlockN n ty -> a+foldr f acc b = B.foldr f acc (unBlock b)++cons :: PrimType ty => ty -> BlockN n ty -> BlockN (n+1) ty+cons e = BlockN . B.cons e . unBlock++snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty+snoc b = BlockN . B.snoc (unBlock b)++sub :: forall i j n ty+     . ( (i <=? n) ~ 'True+       , (j <=? n) ~ 'True+       , (i <=? j) ~ 'True+       , PrimType ty+       , KnownNat i+       , KnownNat j+       , Offsetable ty i+       , Offsetable ty j )+    => BlockN n ty+    -> BlockN (j-i) ty+sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j))++uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n)+       => BlockN n ty+       -> (ty, BlockN (n-1) ty)+uncons b = (indexStatic @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n)))++unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n)+       => BlockN n ty+       -> (BlockN (n-1) ty, ty)+unsnoc b =+    ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1))+    , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1))++splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty)+splitAt b =+    let (left, right) = B.splitAt (toCount @i) (unBlock b)+     in (BlockN left, BlockN right)++elem :: PrimType ty => ty -> BlockN n ty -> Bool+elem e b = B.elem e (unBlock b)++all :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool+all p b = B.all p (unBlock b)++any :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Bool+any p b = B.any p (unBlock b)++find :: PrimType ty => (ty -> Bool) -> BlockN n ty -> Maybe ty+find p b = B.find p (unBlock b)++reverse :: PrimType ty => BlockN n ty -> BlockN n ty+reverse = BlockN . B.reverse . unBlock++sortBy :: PrimType ty => (ty -> ty -> Ordering) -> BlockN n ty -> BlockN n ty+sortBy f b = BlockN (B.sortBy f (unBlock b))++intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty+intersperse sep b = BlockN (B.intersperse sep (unBlock b))++toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty+toCount = natValCountOf (Proxy @n)++toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty+toOffset = natValOffset (Proxy @n)

@@ -0,0 +1,234 @@+-- |+-- Module      : Basement.Sized.List+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- A Nat-sized list abstraction+--+-- Using this module is limited to GHC 7.10 and above.+--+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE AllowAmbiguousTypes       #-}+module Basement.Sized.List+    ( ListN+    , toListN+    , unListN+    , length+    , create+    , createFrom+    , empty+    , singleton+    , uncons+    , cons+    , index+    , indexStatic+    , map+    , elem+    , foldl+    , foldl'+    , foldr+    , append+    , minimum+    , maximum+    , head+    , tail+    , take+    , drop+    , splitAt+    , zip, zip3, zip4, zip5+    , zipWith, zipWith3, zipWith4, zipWith5+    , replicate+    -- * Applicative And Monadic+    , replicateM+    , mapM+    , mapM_+    ) where++import           Data.Proxy+import qualified Data.List+import           Basement.Compat.Base+import           Basement.Nat+import           Basement.NormalForm+import           Basement.Numerical.Additive+import           Basement.Numerical.Subtractive+import           Basement.Types.OffsetSize+import           Basement.Compat.ExtList ((!!))+import qualified Prelude+import qualified Control.Monad as M (replicateM, mapM, mapM_)++impossible :: a+impossible = error "ListN: internal error: the impossible happened"++newtype ListN (n :: Nat) a = ListN { unListN :: [a] }+    deriving (Eq,Ord)++instance Show a => Show (ListN n a) where+    show (ListN l) = show l++instance NormalForm a => NormalForm (ListN n a) where+    toNormalForm (ListN l) = toNormalForm l++toListN :: forall (n :: Nat) a . (KnownNat n, NatWithinBound Int n) => [a] -> Maybe (ListN n a)+toListN l+    | expected == Prelude.fromIntegral (Prelude.length l) = Just (ListN l)+    | otherwise                                           = Nothing+  where+    expected = natValInt (Proxy :: Proxy n)++replicateM :: forall (n :: Nat) m a . (NatWithinBound Int n, Monad m, KnownNat n) => m a -> m (ListN n a)+replicateM action = ListN <$> M.replicateM (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) action++mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b)+mapM f (ListN l) = ListN <$> M.mapM f l++mapM_ :: Monad m => (a -> m b) -> ListN n a -> m ()+mapM_ f (ListN l) = M.mapM_ f l++replicate :: forall (n :: Nat) a . (NatWithinBound Int n, KnownNat n) => a -> ListN n a+replicate a = ListN $ Prelude.replicate (Prelude.fromIntegral $ natVal (Proxy :: Proxy n)) a++uncons :: CmpNat n 0 ~ 'GT => ListN n a -> (a, ListN (n-1) a)+uncons (ListN (x:xs)) = (x, ListN xs)+uncons _ = impossible++cons :: a -> ListN n a -> ListN (n+1) a+cons a (ListN l) = ListN (a : l)++empty :: ListN 0 a+empty = ListN []++length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> Int+length _ = natValInt (Proxy :: Proxy n)++create :: forall a (n :: Nat) . KnownNat n => (Integer -> a) -> ListN n a+create f = ListN $ Prelude.map f [0..(len-1)]+  where+    len = natVal (Proxy :: Proxy n)++createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start)+           => Proxy start -> (Integer -> a) -> ListN n a+createFrom p f = ListN $ Prelude.map f [idx..(idx+len-1)]+  where+    len = natVal (Proxy :: Proxy n)+    idx = natVal p++singleton :: a -> ListN 1 a+singleton a = ListN [a]++elem :: Eq a => a -> ListN n a -> Bool+elem a (ListN l) = Prelude.elem a l++append :: ListN n a -> ListN m a -> ListN (n+m) a+append (ListN l1) (ListN l2) = ListN (l1 <> l2)++maximum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a+maximum (ListN l) = Prelude.maximum l++minimum :: (Ord a, CmpNat n 0 ~ 'GT) => ListN n a -> a+minimum (ListN l) = Prelude.minimum l++head :: CmpNat n 0 ~ 'GT => ListN n a -> a+head (ListN (x:_)) = x+head _ = impossible++tail :: CmpNat n 0 ~ 'GT => ListN n a -> ListN (n-1) a+tail (ListN (_:xs)) = ListN xs+tail _ = impossible++take :: forall a (m :: Nat) (n :: Nat) . (KnownNat m, NatWithinBound Int m, m <= n) => ListN n a -> ListN m a+take (ListN l) = ListN (Prelude.take n l)+  where n = natValInt (Proxy :: Proxy m)++drop :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> ListN m a+drop (ListN l) = ListN (Prelude.drop n l)+  where n = natValInt (Proxy :: Proxy d)++splitAt :: forall a d (m :: Nat) (n :: Nat) . (KnownNat d, NatWithinBound Int d, (n - m) ~ d, m <= n) => ListN n a -> (ListN m a, ListN (n-m) a)+splitAt (ListN l) = let (l1, l2) = Prelude.splitAt n l in (ListN l1, ListN l2)+  where n = natValInt (Proxy :: Proxy d)++indexStatic :: forall i n a . (KnownNat i, CmpNat i n ~ 'LT, Offsetable a i) => ListN n a -> a+indexStatic (ListN l) = l !! (natValOffset (Proxy :: Proxy i))++index :: ListN n ty -> Offset ty -> ty+index (ListN l) ofs = l !! ofs++map :: (a -> b) -> ListN n a -> ListN n b+map f (ListN l) = ListN (Prelude.map f l)++foldl :: (b -> a -> b) -> b -> ListN n a -> b+foldl f acc (ListN l) = Prelude.foldl f acc l++foldl' :: (b -> a -> b) -> b -> ListN n a -> b+foldl' f acc (ListN l) = Data.List.foldl' f acc l++foldr :: (a -> b -> b) -> b -> ListN n a -> b+foldr f acc (ListN l) = Prelude.foldr f acc l++zip :: ListN n a -> ListN n b -> ListN n (a,b)+zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2)++zip3 :: ListN n a -> ListN n b -> ListN n c -> ListN n (a,b,c)+zip3 (ListN x1) (ListN x2) (ListN x3) = ListN (loop x1 x2 x3)+  where loop (l1:l1s) (l2:l2s) (l3:l3s) = (l1,l2,l3) : loop l1s l2s l3s+        loop []       _        _        = []+        loop _        _        _        = impossible++zip4 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n (a,b,c,d)+zip4 (ListN x1) (ListN x2) (ListN x3) (ListN x4) = ListN (loop x1 x2 x3 x4)+  where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) = (l1,l2,l3,l4) : loop l1s l2s l3s l4s+        loop []       _        _        _        = []+        loop _        _        _        _        = impossible++zip5 :: ListN n a -> ListN n b -> ListN n c -> ListN n d -> ListN n e -> ListN n (a,b,c,d,e)+zip5 (ListN x1) (ListN x2) (ListN x3) (ListN x4) (ListN x5) = ListN (loop x1 x2 x3 x4 x5)+  where loop (l1:l1s) (l2:l2s) (l3:l3s) (l4:l4s) (l5:l5s) = (l1,l2,l3,l4,l5) : loop l1s l2s l3s l4s l5s+        loop []       _        _        _        _        = []+        loop _        _        _        _        _        = impossible++zipWith :: (a -> b -> x) -> ListN n a -> ListN n b -> ListN n x+zipWith f (ListN (v1:vs)) (ListN (w1:ws)) = ListN (f v1 w1 : unListN (zipWith f (ListN vs) (ListN ws)))+zipWith _ (ListN [])       _ = ListN []+zipWith _ _                _ = impossible++zipWith3 :: (a -> b -> c -> x)+         -> ListN n a+         -> ListN n b+         -> ListN n c+         -> ListN n x+zipWith3 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) =+    ListN (f v1 w1 x1 : unListN (zipWith3 f (ListN vs) (ListN ws) (ListN xs)))+zipWith3 _ (ListN []) _       _ = ListN []+zipWith3 _ _          _       _ = impossible++zipWith4 :: (a -> b -> c -> d -> x)+         -> ListN n a+         -> ListN n b+         -> ListN n c+         -> ListN n d+         -> ListN n x+zipWith4 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) =+    ListN (f v1 w1 x1 y1 : unListN (zipWith4 f (ListN vs) (ListN ws) (ListN xs) (ListN ys)))+zipWith4 _ (ListN []) _       _       _ = ListN []+zipWith4 _ _          _       _       _ = impossible++zipWith5 :: (a -> b -> c -> d -> e -> x)+         -> ListN n a+         -> ListN n b+         -> ListN n c+         -> ListN n d+         -> ListN n e+         -> ListN n x+zipWith5 f (ListN (v1:vs)) (ListN (w1:ws)) (ListN (x1:xs)) (ListN (y1:ys)) (ListN (z1:zs)) =+    ListN (f v1 w1 x1 y1 z1 : unListN (zipWith5 f (ListN vs) (ListN ws) (ListN xs) (ListN ys) (ListN zs)))+zipWith5 _ (ListN []) _       _       _       _ = ListN []+zipWith5 _ _          _       _       _       _ = impossible

@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds            #-}+module Basement.Sized.UVect+    ( UVect+    , MUVect+    , unUVect+    , toUVect+    , empty+    , singleton+    , replicate+    , thaw+    , freeze+    , index+    , map+    , foldl'+    , foldr+    , cons+    , snoc+    , elem+    , sub+    , uncons+    , unsnoc+    , splitAt+    , all+    , any+    , find+    , reverse+    , sortBy+    , intersperse+    ) where++import           Basement.Compat.Base+import           Basement.Nat+import           Basement.NormalForm+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.PrimType (PrimType)+import qualified Basement.UArray as A+import qualified Basement.UArray.Mutable as A hiding (sub)+import           Data.Proxy++newtype UVect (n :: Nat) a = UVect { unUVect :: A.UArray a } deriving (NormalForm, Eq, Show)+newtype MUVect (n :: Nat) ty st = MUVect { unMUVect :: A.MUArray ty st }++toUVect :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => A.UArray ty -> Maybe (UVect n ty)+toUVect b+    | expected == A.length b = Just (UVect b)+    | otherwise              = Nothing+  where+    expected = toCount @n++empty :: PrimType ty => UVect 0 ty+empty = UVect mempty++singleton :: PrimType ty => ty -> UVect 1 ty+singleton a = UVect (A.singleton a)++create :: forall ty (n :: Nat) . (PrimType ty, Countable ty n, KnownNat n) => (Offset ty -> ty) -> UVect n ty+create f = UVect $ A.create sz f+  where+    sz = natValCountOf (Proxy :: Proxy n)++replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> UVect n ty+replicate a = UVect (A.replicate (toCount @n) a)++thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => UVect n ty -> prim (MUVect n ty (PrimState prim))+thaw b = MUVect <$> A.thaw (unUVect b)++freeze ::  (PrimMonad prim, PrimType ty, Countable ty n) => MUVect n ty (PrimState prim) -> prim (UVect n ty)+freeze b = UVect <$> A.freeze (unMUVect b)++write :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> ty -> prim ()+write (MUVect ma) ofs v = A.write ma ofs v++read :: (PrimMonad prim, PrimType ty) => MUVect n ty (PrimState prim) -> Offset ty -> prim ty+read (MUVect ma) ofs = A.read ma ofs++indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => UVect n ty -> ty+indexStatic b = A.unsafeIndex (unUVect b) (toOffset @i)++index :: forall i n ty . PrimType ty => UVect n ty -> Offset ty -> ty+index b ofs = A.index (unUVect b) ofs++map :: (PrimType a, PrimType b) => (a -> b) -> UVect n a -> UVect n b+map f b = UVect (A.map f (unUVect b))++foldl' :: PrimType ty => (a -> ty -> a) -> a -> UVect n ty -> a+foldl' f acc b = A.foldl' f acc (unUVect b)++foldr :: PrimType ty => (ty -> a -> a) -> a -> UVect n ty -> a+foldr f acc b = A.foldr f acc (unUVect b)++cons :: PrimType ty => ty -> UVect n ty -> UVect (n+1) ty+cons e = UVect . A.cons e . unUVect++snoc :: PrimType ty => UVect n ty -> ty -> UVect (n+1) ty+snoc b = UVect . A.snoc (unUVect b)++sub :: forall i j n ty+     . ( (i <=? n) ~ 'True+       , (j <=? n) ~ 'True+       , (i <=? j) ~ 'True+       , PrimType ty+       , KnownNat i+       , KnownNat j+       , Offsetable ty i+       , Offsetable ty j )+    => UVect n ty+    -> UVect (j-i) ty+sub block = UVect (A.sub (unUVect block) (toOffset @i) (toOffset @j))++uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n)+       => UVect n ty+       -> (ty, UVect (n-1) ty)+uncons b = (indexStatic @0 b, UVect (A.sub (unUVect b) 1 (toOffset @n)))++unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n)+       => UVect n ty+       -> (UVect (n-1) ty, ty)+unsnoc b =+    ( UVect (A.sub (unUVect b) 0 (toOffset @n `offsetSub` 1))+    , A.unsafeIndex (unUVect b) (toOffset @n `offsetSub` 1))++splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => UVect n ty -> (UVect i ty, UVect (n-i) ty)+splitAt b =+    let (left, right) = A.splitAt (toCount @i) (unUVect b)+     in (UVect left, UVect right)++elem :: PrimType ty => ty -> UVect n ty -> Bool+elem e b = A.elem e (unUVect b)++all :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool+all p b = A.all p (unUVect b)++any :: PrimType ty => (ty -> Bool) -> UVect n ty -> Bool+any p b = A.any p (unUVect b)++find :: PrimType ty => (ty -> Bool) -> UVect n ty -> Maybe ty+find p b = A.find p (unUVect b)++reverse :: PrimType ty => UVect n ty -> UVect n ty+reverse = UVect . A.reverse . unUVect++sortBy :: PrimType ty => (ty -> ty -> Ordering) -> UVect n ty -> UVect n ty+sortBy f b = UVect (A.sortBy f (unUVect b))++intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> UVect n ty -> UVect (n+n-1) ty+intersperse sep b = UVect (A.intersperse sep (unUVect b))++toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty+toCount = natValCountOf (Proxy @n)++toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty+toOffset = natValOffset (Proxy @n)

@@ -0,0 +1,161 @@+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds            #-}+module Basement.Sized.Vect+    ( Vect+    , MVect+    , unVect+    , toVect+    , empty+    , singleton+    , replicate+    , thaw+    , freeze+    , index+    , map+    , foldl'+    , foldr+    , cons+    , snoc+    , elem+    , sub+    , uncons+    , unsnoc+    , splitAt+    , all+    , any+    , find+    , reverse+    , sortBy+    , intersperse+    ) where++import           Basement.Compat.Base+import           Basement.Nat+import           Basement.NormalForm+import           Basement.Types.OffsetSize+import           Basement.Monad+import           Basement.PrimType (PrimType)+import qualified Basement.BoxedArray as A+--import qualified Basement.BoxedArray.Mutable as A hiding (sub)+import           Data.Proxy++newtype Vect (n :: Nat) a = Vect { unVect :: A.Array a } deriving (NormalForm, Eq, Show)+newtype MVect (n :: Nat) ty st = MVect { unMVect :: A.MArray ty st }++instance Functor (Vect n) where+    fmap = map++toVect :: forall n ty . (KnownNat n, Countable ty n) => A.Array ty -> Maybe (Vect n ty)+toVect b+    | expected == A.length b = Just (Vect b)+    | otherwise = Nothing+  where+    expected = toCount @n++empty :: Vect 0 ty+empty = Vect A.empty++singleton :: ty -> Vect 1 ty+singleton a = Vect (A.singleton a)++create :: forall a (n :: Nat) . (Countable a n, KnownNat n) => (Offset a -> a) -> Vect n a+create f = Vect $ A.create sz f+  where+    sz = natValCountOf (Proxy :: Proxy n)++replicate :: forall n ty . (KnownNat n, Countable ty n) => ty -> Vect n ty+replicate a = Vect (A.replicate (toCount @n) a)++thaw :: (KnownNat n, PrimMonad prim) => Vect n ty -> prim (MVect n ty (PrimState prim))+thaw b = MVect <$> A.thaw (unVect b)++freeze ::  (PrimMonad prim, Countable ty n) => MVect n ty (PrimState prim) -> prim (Vect n ty)+freeze b = Vect <$> A.freeze (unMVect b)++write :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> ty -> prim ()+write (MVect ma) ofs v = A.write ma ofs v++read :: PrimMonad prim => MVect n ty (PrimState prim) -> Offset ty -> prim ty+read (MVect ma) ofs = A.read ma ofs++indexStatic :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, Offsetable ty i) => Vect n ty -> ty+indexStatic b = A.unsafeIndex (unVect b) (toOffset @i)++index :: Vect n ty -> Offset ty -> ty+index b ofs = A.index (unVect b) ofs++map :: (a -> b) -> Vect n a -> Vect n b+map f b = Vect (fmap f (unVect b))++foldl' :: (a -> ty -> a) -> a -> Vect n ty -> a+foldl' f acc b = A.foldl' f acc (unVect b)++foldr :: (ty -> a -> a) -> a -> Vect n ty -> a+foldr f acc b = A.foldr f acc (unVect b)++cons :: ty -> Vect n ty -> Vect (n+1) ty+cons e = Vect . A.cons e . unVect++snoc :: Vect n ty -> ty -> Vect (n+1) ty+snoc b = Vect . A.snoc (unVect b)++sub :: forall i j n ty+     . ( (i <=? n) ~ 'True+       , (j <=? n) ~ 'True+       , (i <=? j) ~ 'True+       , KnownNat i+       , KnownNat j+       , Offsetable ty i+       , Offsetable ty j )+    => Vect n ty+    -> Vect (j-i) ty+sub block = Vect (A.sub (unVect block) (toOffset @i) (toOffset @j))++uncons :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n)+       => Vect n ty+       -> (ty, Vect (n-1) ty)+uncons b = (indexStatic @0 b, Vect (A.sub (unVect b) 1 (toOffset @n)))++unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, Offsetable ty n)+       => Vect n ty+       -> (Vect (n-1) ty, ty)+unsnoc b =+    ( Vect (A.sub (unVect b) 0 (toOffset @n `offsetSub` 1))+    , A.unsafeIndex (unVect b) (toOffset @n `offsetSub` 1))++splitAt :: forall i n ty . (CmpNat i n ~ 'LT, KnownNat i, Countable ty i) => Vect n ty -> (Vect i ty, Vect (n-i) ty)+splitAt b =+    let (left, right) = A.splitAt (toCount @i) (unVect b)+     in (Vect left, Vect right)++elem :: Eq ty => ty -> Vect n ty -> Bool+elem e b = A.elem e (unVect b)++all :: (ty -> Bool) -> Vect n ty -> Bool+all p b = A.all p (unVect b)++any :: (ty -> Bool) -> Vect n ty -> Bool+any p b = A.any p (unVect b)++find :: (ty -> Bool) -> Vect n ty -> Maybe ty+find p b = A.find p (unVect b)++reverse :: Vect n ty -> Vect n ty+reverse = Vect . A.reverse . unVect++sortBy :: (ty -> ty -> Ordering) -> Vect n ty -> Vect n ty+sortBy f b = Vect (A.sortBy f (unVect b))++intersperse :: (CmpNat n 1 ~ 'GT) => ty -> Vect n ty -> Vect (n+n-1) ty+intersperse sep b = Vect (A.intersperse sep (unVect b))++toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty+toCount = natValCountOf (Proxy @n)++toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty+toOffset = natValOffset (Proxy @n)

@@ -98,7 +98,7 @@ import qualified Basement.UArray           as Vec import qualified Basement.UArray           as C import qualified Basement.UArray.Mutable   as MVec-import           Basement.Block.Mutable (MutableBlock(..))+import           Basement.Block.Mutable (Block(..), MutableBlock(..)) import           Basement.Compat.Bifunctor import           Basement.Compat.Base import           Basement.Compat.Natural@@ -471,8 +471,8 @@   where     k = C.onBackend goVec (\_ -> pure . goAddr) arr     (C.ValidRange !start !end) = offsetsValidRange arr-    goVec ba = let k = BackendBA.revFindIndexPredicate predicate ba start end-                in if k == end then end else PrimBA.nextSkip ba k+    goVec (Block ba) = let k = BackendBA.revFindIndexPredicate predicate ba start end+                        in if k == end then end else PrimBA.nextSkip ba k     goAddr (Ptr addr) =         let k = BackendAddr.revFindIndexPredicate predicate addr start end          in if k == end then end else PrimAddr.nextSkip addr k@@ -604,7 +604,7 @@     | otherwise    = C.onBackend goVec (\_ -> pure . goAddr) arr   where     (C.ValidRange !start !end) = offsetsValidRange arr-    goVec ma = PrimBA.length ma start end+    goVec (Block ma) = PrimBA.length ma start end     goAddr (Ptr ptr) = PrimAddr.length ptr start end  -- | Replicate a character @c@ @n@ times to create a string of length @n@@@ -785,7 +785,7 @@ filter :: (Char -> Bool) -> String -> String filter predicate (String arr) = runST $ do     (finalSize, dst) <- newNative sz $ \(MutableBlock mba) ->-        C.onBackendPrim (\ba -> BackendBA.copyFilter predicate sz mba ba start)+        C.onBackendPrim (\(Block ba) -> BackendBA.copyFilter predicate sz mba ba start)                         (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start)                         arr     freezeShrink finalSize dst@@ -1391,17 +1391,17 @@     | otherwise               = Nothing  all :: (Char -> Bool) -> String -> Bool-all predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr+all predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr   where     !(C.ValidRange start end) = C.offsetsValidRange arr-    goNative ba = PrimBA.all predicate ba start end+    goBA (Block ba)   = PrimBA.all predicate ba start end     goAddr (Ptr addr) = PrimAddr.all predicate addr start end  any :: (Char -> Bool) -> String -> Bool-any predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr+any predicate (String arr) = C.onBackend goBA (\_ -> pure . goAddr) arr   where     !(C.ValidRange start end) = C.offsetsValidRange arr-    goNative ba = PrimBA.any predicate ba start end+    goBA (Block ba)   = PrimBA.any predicate ba start end     goAddr (Ptr addr) = PrimAddr.any predicate addr start end  -- | Transform string @src@ to base64 binary representation.

@@ -13,6 +13,8 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Basement.UArray     ( UArray(..)     , PrimType(..)@@ -125,7 +127,7 @@ import           Basement.UArray.Base import           Basement.Block (Block(..), MutableBlock(..)) import qualified Basement.Block as BLK-import qualified Basement.Block.Base as BLK (touch, unsafeWrite)+import qualified Basement.Block.Base as BLK (withPtr, unsafeWrite) import           Basement.UArray.Mutable hiding (sub, copyToPtr) import           Basement.Numerical.Additive import           Basement.Numerical.Subtractive@@ -134,9 +136,16 @@ import           Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr) import qualified Basement.Compat.ExtList as List import qualified Basement.Base16 as Base16+import qualified Basement.Alg.Native.Prim as PrimBA import qualified Basement.Alg.Native.PrimArray as PrimBA+import qualified Basement.Alg.Foreign.Prim as PrimAddr import qualified Basement.Alg.Foreign.PrimArray as PrimAddr+import qualified Basement.Alg.Mutable as MutAlg +instance (PrimMonad prim, PrimType ty) => MutAlg.RandomAccess (Ptr ty) prim ty where+    read (Ptr addr) = PrimAddr.primRead addr+    write (Ptr addr) = PrimAddr.primWrite addr+ -- | Return the element at a specific index from an array. -- -- If the index @n is out of bounds, an error is raised.@@ -284,7 +293,7 @@   where     !(Offset os@(I# os#)) = offsetInBytes $ offset arr     !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ length arr-    copyBa ba = primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #)+    copyBa (Block ba) = primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #)     copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes  withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty)@@ -293,7 +302,7 @@         -> prim a withPtr a f     | isPinned a == Pinned =-        onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os) <* BLK.touch (Block ba))+        onBackendPrim (\blk  -> BLK.withPtr  blk  $ \ptr -> f (ptr `plusPtr` os))                       (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))                       a     | otherwise = do@@ -374,10 +383,10 @@   where     !end = start `offsetPlusE` len     !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr-    goBa ba = PrimBA.findIndexElem ty ba start end+    goBa (Block ba) = PrimBA.findIndexElem ty ba start end     goAddr _ (Ptr addr) = PrimAddr.findIndexElem ty addr start end {-# NOINLINE [3] breakElem #-}-{-# RULES "breakElem Word8" [3] breakElem = breakElemByte #-}+{-# RULES "breakElem Word8" [4] breakElem = breakElemByte #-} {-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}  breakElemByte :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8)@@ -389,7 +398,7 @@   where     !end = start `offsetPlusE` len     !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr-    goBa ba = sysHsMemFindByteBa ba start end ty+    goBa (Block ba) = sysHsMemFindByteBa ba start end ty     goAddr _ (Ptr addr) = sysHsMemFindByteAddr addr start end ty  -- | Similar to breakElem specialized to split on linefeed@@ -412,7 +421,7 @@     !(k1, k2) = onBackend goBa (\fptr -> pure . goAddr fptr) arr     lineFeed = 0xa     carriageReturn = 0xd-    goBa ba =+    goBa (Block ba) =         let k = sysHsMemFindByteBa ba start end lineFeed             cr = k > start && PrimBA.primIndex ba (k `offsetSub` 1) == carriageReturn          in (if cr then k `offsetSub` 1 else k, k)@@ -476,7 +485,7 @@     !k = onBackend goBa (\_ -> pure . goAddr) arr     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa ba = PrimBA.findIndexElem ty ba start end+    goBa (Block ba) = PrimBA.findIndexElem ty ba start end     goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} @@ -488,7 +497,7 @@     !k = onBackend goBa (\_ -> pure . goAddr) arr     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa ba = PrimBA.revFindIndexElem ty ba start end+    goBa (Block ba) = PrimBA.revFindIndexElem ty ba start end     goAddr (Ptr addr) = PrimAddr.revFindIndexElem ty addr start end {-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} @@ -500,7 +509,7 @@     !k = onBackend goBa (\_ -> pure . goAddr) arr     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa ba = PrimBA.findIndexPredicate predicate ba start end+    goBa (Block ba) = PrimBA.findIndexPredicate predicate ba start end     goAddr (Ptr addr) = PrimAddr.findIndexPredicate predicate addr start end  {-@@ -540,7 +549,7 @@     !k = onBackend goBa (\_ -> pure . goAddr) arr     !start = offset arr     !end   = start `offsetPlusE` length arr-    goBa ba = PrimBA.revFindIndexPredicate predicate ba start end+    goBa (Block ba) = PrimBA.revFindIndexPredicate predicate ba start end     goAddr (Ptr addr) = PrimAddr.revFindIndexPredicate predicate addr start end {-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} @@ -549,7 +558,7 @@   where     !start = offset arr     !end = start `offsetPlusE` length arr-    goBa ba = PrimBA.findIndexElem ty ba start end+    goBa (Block ba) = PrimBA.findIndexElem ty ba start end     goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end {-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-} @@ -636,19 +645,18 @@     unsafeFreeze mvec   where     !len = length vec-    !end = 0 `offsetPlusE` len     !start = offset vec -    goNative :: MutableByteArray# (PrimState (ST s)) -> ST s ()-    goNative mba = PrimBA.inplaceSortBy ford mba start end+    goNative :: MutableBlock ty s -> ST s ()+    goNative mb = MutAlg.inplaceSortBy ford start len mb     goAddr :: Ptr ty -> ST s ()-    goAddr (Ptr addr) = PrimAddr.inplaceSortBy ford addr start end+    goAddr (Ptr addr) = MutAlg.inplaceSortBy ford start len (Ptr addr :: Ptr ty) {-# SPECIALIZE [3] sortBy :: (Word8 -> Word8 -> Ordering) -> UArray Word8 -> UArray Word8 #-}  filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty filter predicate arr = runST $ do     (newLen, ma) <- newNative (length arr) $ \(MutableBlock mba) ->-            onBackendPrim (\ba -> PrimBA.filter predicate mba ba start end)+            onBackendPrim (\(Block ba) -> PrimBA.filter predicate mba ba start end)                           (\fptr -> withFinalPtr fptr $ \(Ptr addr) ->                                         PrimAddr.filter predicate mba addr start end)                           arr@@ -672,8 +680,8 @@     !start = offset a     !endI = sizeAsOffset ((start + end) - Offset 1) -    goNative :: MutableBlock ty s -> ByteArray# -> ST s ()-    goNative !ma !ba = loop 0+    goNative :: MutableBlock ty s -> Block ty -> ST s ()+    goNative !ma (Block !ba) = loop 0       where         loop !i             | i == end  = pure ()@@ -717,7 +725,7 @@       True -> error "Basement.UArray.replace: empty needle"       False -> do         let insertionPoints = indices needle haystack-        let !occs           = List.length insertionPoints+        let !(CountOf occs) = List.length insertionPoints         let !newLen         = haystackLen `sizeSub` (multBy needleLen occs) + (multBy replacementLen occs)         ms <- new newLen         loop ms (Offset 0) (Offset 0) insertionPoints@@ -765,22 +773,22 @@         | otherwise  = unsafeIndex vec i `f` loop (i+1)  foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a-foldl' f initialAcc arr = onBackend goNative (\_ -> pure . goAddr) arr+foldl' f initialAcc arr = onBackend goBA (\_ -> pure . goAddr) arr   where     !len = length arr     !start = offset arr     !end = start `offsetPlusE` len-    goNative ba = PrimBA.foldl f initialAcc ba start end+    goBA (Block ba) = PrimBA.foldl f initialAcc ba start end     goAddr (Ptr ptr) = PrimAddr.foldl f initialAcc ptr start end {-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-}  foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty-foldl1' f (NonEmpty arr) = onBackend goNative (\_ -> pure . goAddr) arr+foldl1' f (NonEmpty arr) = onBackend goBA (\_ -> pure . goAddr) arr   where     !len = length arr     !start = offset arr     !end = start `offsetPlusE` len-    goNative ba = PrimBA.foldl1 f ba start end+    goBA (Block ba) = PrimBA.foldl1 f ba start end     goAddr (Ptr ptr) = PrimAddr.foldl1 f ptr start end {-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (UArray Word8) -> Word8 #-} @@ -789,7 +797,7 @@                in foldr f (unsafeIndex initialAcc 0) rest  all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool-all predicate arr = onBackend (\ba -> PrimBA.all predicate ba start end)+all predicate arr = onBackend (\(Block ba) -> PrimBA.all predicate ba start end)                               (\_ (Ptr ptr) -> pure (PrimAddr.all predicate ptr start end))                               arr   where@@ -798,7 +806,7 @@ {-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-}  any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool-any predicate arr = onBackend (\ba -> PrimBA.any predicate ba start end)+any predicate arr = onBackend (\(Block ba) -> PrimBA.any predicate ba start end)                               (\_ (Ptr ptr) -> pure (PrimAddr.any predicate ptr start end))                               arr   where

@@ -44,7 +44,6 @@     , compare     , copyAt     , unsafeCopyAtRO-    , touch     , toBlock     -- * temporary     , pureST@@ -66,7 +65,6 @@ import           Basement.NormalForm import           Basement.Block (MutableBlock(..), Block(..)) import qualified Basement.Block as BLK-import qualified Basement.Block.Base as BLK (touch) import qualified Basement.Block.Mutable as MBLK import           Basement.Numerical.Additive import           Basement.Bindings.Memory@@ -259,29 +257,29 @@ copy array = runST (thaw array >>= unsafeFreeze)  -onBackend :: (ByteArray# -> a)+onBackend :: (Block ty -> a)           -> (FinalPtr ty -> Ptr ty -> ST s a)           -> UArray ty           -> a-onBackend onBa _      (UArray _ _ (UArrayBA (Block ba))) = onBa ba-onBackend _    onAddr (UArray _ _ (UArrayAddr fptr))     = withUnsafeFinalPtr fptr (onAddr fptr)+onBackend onBa _      (UArray _ _ (UArrayBA ba))     = onBa ba+onBackend _    onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr (onAddr fptr) {-# INLINE onBackend #-}  onBackendPrim :: PrimMonad prim-              => (ByteArray# -> prim a)+              => (Block ty -> prim a)               -> (FinalPtr ty -> prim a)               -> UArray ty               -> prim a-onBackendPrim onBa _      (UArray _ _ (UArrayBA (Block ba))) = onBa ba-onBackendPrim _    onAddr (UArray _ _ (UArrayAddr fptr))     = onAddr fptr+onBackendPrim onBa _      (UArray _ _ (UArrayBA ba))     = onBa ba+onBackendPrim _    onAddr (UArray _ _ (UArrayAddr fptr)) = onAddr fptr {-# INLINE onBackendPrim #-}  onMutableBackend :: PrimMonad prim-                 => (MutableByteArray# (PrimState prim) -> prim a)+                 => (MutableBlock ty (PrimState prim) -> prim a)                  -> (FinalPtr ty -> prim a)                  -> MUArray ty (PrimState prim)                  -> prim a-onMutableBackend onMba _      (MUArray _ _ (MUArrayMBA (MutableBlock mba)))   = onMba mba+onMutableBackend onMba _      (MUArray _ _ (MUArrayMBA mba))   = onMba mba onMutableBackend _     onAddr (MUArray _ _ (MUArrayAddr fptr)) = onAddr fptr {-# INLINE onMutableBackend #-} @@ -315,7 +313,7 @@ -- | make an array from a list of elements. vFromList :: forall ty . PrimType ty => [ty] -> UArray ty vFromList l = runST $ do-    ((), ma) <- newNative (CountOf len) copyList+    ((), ma) <- newNative len copyList     unsafeFreeze ma   where     len = List.length l@@ -591,10 +589,6 @@         unsafeCopyAtRO r i x (Offset 0) lx         doCopy r (i `offsetPlusE` lx) xs       where lx = length x--touch :: PrimMonad prim => UArray ty -> prim ()-touch (UArray _ _ (UArrayBA blk))    = BLK.touch blk-touch (UArray _ _ (UArrayAddr fptr)) = touchFinalPtr fptr  -- | Create a Block from a UArray. --

@@ -125,7 +125,7 @@     sz           = primSizeInBytes (Proxy :: Proxy ty)     !(Offset os) = offsetOfE sz start withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA mb)) f-    | BLK.isMutablePinned mb == Pinned = MBLK.mutableWithAddr mb (\ptr -> f (ptr `plusPtr` os))+    | BLK.isMutablePinned mb == Pinned = MBLK.mutableWithPtr mb (\ptr -> f (ptr `plusPtr` os))     | otherwise                        = do         trampoline <- newPinned vecSz         if not skipCopy@@ -168,7 +168,7 @@     !(CountOf bytes@(I# bytes#)) = sizeOfE sz count     !(Offset od@(I# od#)) = offsetOfE sz ofs -    copyNative mba = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)+    copyNative (MutableBlock mba) = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)     copyPtr fptr = withFinalPtr fptr $ \dst ->         unsafePrimFromIO $ copyBytes (dst `plusPtr` od) src bytes @@ -179,7 +179,7 @@           -> prim () copyToPtr marr dst@(Ptr dst#) = onMutableBackend copyNative copyPtr marr   where-    copyNative mba = primitive $ \s1 ->+    copyNative (MutableBlock mba) = primitive $ \s1 ->         case unsafeFreezeByteArray# mba s1 of             (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s2, () #)     copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr ->

@@ -148,20 +148,20 @@ {-# INLINE [0] sFromList #-}  next :: String -> Offset8 -> Step-next (String array) !n = Vec.onBackend nextNative nextAddr array+next (String array) !n = Vec.onBackend nextBA nextAddr array   where     !start = Vec.offset array     reoffset (Step a ofs) = Step a (ofs `offsetSub` start)-    nextNative ba        = reoffset (PrimBA.next ba (start + n))-    nextAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.next ptr (start + n))+    nextBA (BLK.Block ba) = reoffset (PrimBA.next ba (start + n))+    nextAddr _ (Ptr ptr)  = pureST $ reoffset (PrimAddr.next ptr (start + n))  prev :: String -> Offset8 -> StepBack-prev (String array) !n = Vec.onBackend prevNative prevAddr array+prev (String array) !n = Vec.onBackend prevBA prevAddr array   where     !start = Vec.offset array     reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start)-    prevNative ba        = reoffset (PrimBA.prev ba (start + n))-    prevAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.prev ptr (start + n))+    prevBA (BLK.Block ba) = reoffset (PrimBA.prev ba (start + n))+    prevAddr _ (Ptr ptr)  = pureST $ reoffset (PrimAddr.prev ptr (start + n))  -- A variant of 'next' when you want the next character -- to be ASCII only.@@ -176,7 +176,7 @@  write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 write (MutableString marray) ofs c =-    MVec.onMutableBackend (\mba -> PrimBA.write mba (start + ofs) c)+    MVec.onMutableBackend (\(BLK.MutableBlock mba) -> PrimBA.write mba (start + ofs) c)                           (\fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c)                           marray   where start = MVec.mutableOffset marray

@@ -1,5 +1,5 @@ name:                basement-version:             0.0.2+version:             0.0.3 synopsis:            Foundation scrap box of array & string description:         Foundation most basic primitives without any dependencies homepage:            https://github.com/haskell-foundation/foundation#readme@@ -79,16 +79,25 @@                      Basement.Compat.Primitive                      Basement.Compat.PrimTypes                      Basement.Compat.MonadTrans+                     Basement.Compat.Semigroup                      Basement.Compat.Natural                      Basement.Compat.NumLiteral                      Basement.Compat.Typeable   if impl(ghc >= 8.0)     exposed-modules: Basement.BlockN+                   , Basement.Sized.Block+                   , Basement.Sized.UVect+                   , Basement.Sized.Vect+  if impl(ghc >= 7.10)+    exposed-modules:+                     Basement.Sized.List    other-modules:                      Basement.Error                      Basement.Show                      Basement.Runtime++                     Basement.Alg.Mutable                       Basement.Alg.Native.Prim                      Basement.Alg.Native.UTF8