Initial commit

bundled/Basement/Sized/Block.hs

@@ -0,0 +1,283 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Sized.Block
+-- License     : BSD-style
+-- Maintainer  : Haskell Foundation
+--
+-- A Nat-sized version of Block
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeOperators              #-}
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE NoStarIsType               #-}
+#endif
+
+module Basement.Sized.Block
+    ( BlockN
+    , MutableBlockN
+    , length
+    , lengthBytes
+    , toBlockN
+    , toBlock
+    , new
+    , newPinned
+    , singleton
+    , replicate
+    , thaw
+    , freeze
+    , index
+    , indexStatic
+    , map
+    , foldl'
+    , foldr
+    , cons
+    , snoc
+    , elem
+    , sub
+    , uncons
+    , unsnoc
+    , splitAt
+    , all
+    , any
+    , find
+    , reverse
+    , sortBy
+    , intersperse
+    , withPtr
+    , withMutablePtr
+    , withMutablePtrHint
+    , cast
+    , mutableCast
+    ) where
+
+import           Data.Proxy (Proxy(..))
+import           Basement.Compat.Base
+import           Basement.Numerical.Additive (scale)
+import           Basement.Block (Block, MutableBlock(..), unsafeIndex)
+import qualified Basement.Block as B
+import qualified Basement.Block.Base as B
+import           Basement.Monad (PrimMonad, PrimState)
+import           Basement.Nat
+import           Basement.Types.OffsetSize
+import           Basement.NormalForm
+import           Basement.PrimType (PrimType, PrimSize, primSizeInBytes)
+
+-- | Sized version of 'Block'
+--
+newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a }
+  deriving (NormalForm, Eq, Show, Data, Ord)
+
+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
+
+length :: forall n ty
+        . (KnownNat n, Countable ty n)
+       => BlockN n ty
+       -> CountOf ty
+length _ = toCount @n
+
+lengthBytes :: forall n ty
+             . PrimType ty
+            => BlockN n ty
+            -> CountOf Word8
+lengthBytes = B.lengthBytes . unBlock
+
+toBlock :: BlockN n ty -> Block ty
+toBlock = unBlock
+
+cast :: forall n m a b
+      . ( PrimType a, PrimType b
+        , KnownNat n, KnownNat m
+        , ((PrimSize b) * m) ~ ((PrimSize a) * n)
+        )
+      => BlockN n a
+      -> BlockN m b
+cast (BlockN b) = BlockN (B.unsafeCast b)
+
+mutableCast :: forall n m a b st
+             . ( PrimType a, PrimType b
+             , KnownNat n, KnownNat m
+             , ((PrimSize b) * m) ~ ((PrimSize a) * n)
+             )
+            => MutableBlockN n a st
+            -> MutableBlockN m b st
+mutableCast (MutableBlockN b) = MutableBlockN (B.unsafeRecast b)
+
+-- | Create a new unpinned mutable block of a specific N size of 'ty' elements
+--
+-- If the size exceeds a GHC-defined threshold, then the memory will be
+-- pinned. To be certain about pinning status with small size, use 'newPinned'
+new :: forall n ty prim
+     . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim)
+    => prim (MutableBlockN n ty (PrimState prim))
+new = MutableBlockN <$> B.new (toCount @n)
+
+-- | Create a new pinned mutable block of a specific N size of 'ty' elements
+newPinned :: forall n ty prim
+           . (PrimType ty, KnownNat n, Countable ty n, PrimMonad prim)
+          => prim (MutableBlockN n ty (PrimState prim))
+newPinned = MutableBlockN <$> B.newPinned (toCount @n)
+
+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)
+
+-- | Get a Ptr pointing to the data in the Block.
+--
+-- Since a Block is immutable, this Ptr shouldn't be
+-- to use to modify the contents
+--
+-- If the Block is pinned, then its address is returned as is,
+-- however if it's unpinned, a pinned copy of the Block is made
+-- before getting the address.
+withPtr :: (PrimMonad prim, KnownNat n)
+        => BlockN n ty
+        -> (Ptr ty -> prim a)
+        -> prim a
+withPtr b = B.withPtr (unBlock b)
+
+-- | Create a pointer on the beginning of the MutableBlock
+-- and call a function 'f'.
+--
+-- The mutable block can be mutated by the 'f' function
+-- and the change will be reflected in the mutable block
+--
+-- If the mutable block is unpinned, a trampoline buffer
+-- is created and the data is only copied when 'f' return.
+--
+-- it is all-in-all highly inefficient as this cause 2 copies
+withMutablePtr :: (PrimMonad prim, KnownNat n)
+               => MutableBlockN n ty (PrimState prim)
+               -> (Ptr ty -> prim a)
+               -> prim a
+withMutablePtr mb = B.withMutablePtr (unMBlock mb)
+
+-- | Same as 'withMutablePtr' but allow to specify 2 optimisations
+-- which is only useful when the MutableBlock is unpinned and need
+-- a pinned trampoline to be called safely.
+--
+-- If skipCopy is True, then the first copy which happen before
+-- the call to 'f', is skipped. The Ptr is now effectively
+-- pointing to uninitialized data in a new mutable Block.
+--
+-- If skipCopyBack is True, then the second copy which happen after
+-- the call to 'f', is skipped. Then effectively in the case of a
+-- trampoline being used the memory changed by 'f' will not
+-- be reflected in the original Mutable Block.
+--
+-- If using the wrong parameters, it will lead to difficult to
+-- debug issue of corrupted buffer which only present themselves
+-- with certain Mutable Block that happened to have been allocated
+-- unpinned.
+--
+-- If unsure use 'withMutablePtr', which default to *not* skip
+-- any copy.
+withMutablePtrHint :: forall n ty prim a . (PrimMonad prim, KnownNat n)
+                   => Bool -- ^ hint that the buffer doesn't need to have the same value as the mutable block when calling f
+                   -> Bool -- ^ hint that the buffer is not supposed to be modified by call of f
+                   -> MutableBlockN n ty (PrimState prim)
+                   -> (Ptr ty -> prim a)
+                   -> prim a
+withMutablePtrHint skipCopy skipCopyBack (MutableBlockN mb) f =
+    B.withMutablePtrHint skipCopy skipCopyBack mb f

bundled/Basement/Sized/List.hs

@@ -0,0 +1,389 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- 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       #-}
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE DeriveGeneric             #-}
+{-# LANGUAGE FlexibleContexts          #-}
+module Basement.Sized.List
+    ( ListN
+    , toListN
+    , toListN_
+    , unListN
+    , length
+    , create
+    , createFrom
+    , empty
+    , singleton
+    , uncons
+    , cons
+    , unsnoc
+    , snoc
+    , index
+    , indexStatic
+    , updateAt
+    , map
+    , mapi
+    , elem
+    , foldl
+    , foldl'
+    , foldl1'
+    , scanl'
+    , scanl1'
+    , foldr
+    , foldr1
+    , reverse
+    , append
+    , minimum
+    , maximum
+    , head
+    , tail
+    , init
+    , take
+    , drop
+    , splitAt
+    , zip, zip3, zip4, zip5
+    , unzip
+    , zipWith, zipWith3, zipWith4, zipWith5
+    , replicate
+    -- * Applicative And Monadic
+    , replicateM
+    , sequence
+    , sequence_
+    , mapM
+    , mapM_
+    ) where
+
+import           Data.Proxy
+import qualified Data.List
+import           Basement.Compat.Base
+import           Basement.Compat.CallStack
+import           Basement.Compat.Natural
+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_, sequence, sequence_)
+
+impossible :: HasCallStack => a
+impossible = error "ListN: internal error: the impossible happened"
+
+-- | A Typed-level sized List equivalent to [a]
+newtype ListN (n :: Nat) a = ListN { unListN :: [a] }
+    deriving (Eq,Ord,Typeable,Generic)
+
+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
+
+-- | Try to create a ListN from a List, succeeding if the length is correct
+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)
+
+-- | Create a ListN from a List, expecting a given length
+--
+-- If this list contains more or less than the expected length of the resulting type,
+-- then an asynchronous error is raised. use 'toListN' for a more friendly functions
+toListN_ :: forall n a . (HasCallStack, NatWithinBound Int n, KnownNat n) => [a] -> ListN n a
+toListN_ l
+    | expected == got = ListN l
+    | otherwise       = error ("toListN_: expecting list of " <> show expected <> " elements, got " <> show got <> " elements")
+  where
+    expected = natValInt (Proxy :: Proxy n)
+    got      = Prelude.length l
+
+-- | performs a monadic action n times, gathering the results in a List of size 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
+
+-- | Evaluate each monadic action in the list sequentially, and collect the results.
+sequence :: Monad m => ListN n (m a) -> m (ListN n a)
+sequence (ListN l) = ListN <$> M.sequence l
+
+-- | Evaluate each monadic action in the list sequentially, and ignore the results.
+sequence_ :: Monad m => ListN n (m a) -> m ()
+sequence_ (ListN l) = M.sequence_ l
+
+-- | Map each element of a List to a monadic action, evaluate these
+-- actions sequentially and collect the results
+mapM :: Monad m => (a -> m b) -> ListN n a -> m (ListN n b)
+mapM f (ListN l) = ListN <$> M.mapM f l
+
+-- | Map each element of a List to a monadic action, evaluate these
+-- actions sequentially and ignore the results
+mapM_ :: Monad m => (a -> m b) -> ListN n a -> m ()
+mapM_ f (ListN l) = M.mapM_ f l
+
+-- | Create a list of n elements where each element is the element in argument
+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
+
+-- | Decompose a list into its head and tail.
+uncons :: (1 <= n) => ListN n a -> (a, ListN (n-1) a)
+uncons (ListN (x:xs)) = (x, ListN xs)
+uncons _ = impossible
+
+-- | prepend an element to the list
+cons :: a -> ListN n a -> ListN (n+1) a
+cons a (ListN l) = ListN (a : l)
+
+-- | Decompose a list into its first elements and the last.
+unsnoc :: (1 <= n) => ListN n a -> (ListN (n-1) a, a)
+unsnoc (ListN l) = (ListN $ Data.List.init l, Data.List.last l)
+
+-- | append an element to the list
+snoc :: ListN n a -> a -> ListN (n+1) a
+snoc (ListN l) a = ListN (l Prelude.++ [a])
+
+-- | Create an empty list of a
+empty :: ListN 0 a
+empty = ListN []
+
+-- | Get the length of a list
+length :: forall a (n :: Nat) . (KnownNat n, NatWithinBound Int n) => ListN n a -> CountOf a
+length _ = CountOf $ natValInt (Proxy :: Proxy n)
+
+-- | Create a new list of size n, repeately calling f from 0 to n-1
+create :: forall a (n :: Nat) . KnownNat n => (Natural -> a) -> ListN n a
+create f = ListN $ Prelude.map (f . Prelude.fromIntegral) [0..(len-1)]
+  where
+    len = natVal (Proxy :: Proxy n)
+
+-- | Same as create but apply an offset
+createFrom :: forall a (n :: Nat) (start :: Nat) . (KnownNat n, KnownNat start)
+           => Proxy start -> (Natural -> a) -> ListN n a
+createFrom p f = ListN $ Prelude.map (f . Prelude.fromIntegral) [idx..(idx+len-1)]
+  where
+    len = natVal (Proxy :: Proxy n)
+    idx = natVal p
+
+-- | create a list of 1 element
+singleton :: a -> ListN 1 a
+singleton a = ListN [a]
+
+-- | Check if a list contains the element a
+elem :: Eq a => a -> ListN n a -> Bool
+elem a (ListN l) = Prelude.elem a l
+
+-- | Append 2 list together returning the new list
+append :: ListN n a -> ListN m a -> ListN (n+m) a
+append (ListN l1) (ListN l2) = ListN (l1 <> l2)
+
+-- | Get the maximum element of a list
+maximum :: (Ord a, 1 <= n) => ListN n a -> a
+maximum (ListN l) = Prelude.maximum l
+
+-- | Get the minimum element of a list
+minimum :: (Ord a, 1 <= n) => ListN n a -> a
+minimum (ListN l) = Prelude.minimum l
+
+-- | Get the head element of a list
+head :: (1 <= n) => ListN n a -> a
+head (ListN (x:_)) = x
+head _ = impossible
+
+-- | Get the tail of a list
+tail :: (1 <= n) => ListN n a -> ListN (n-1) a
+tail (ListN (_:xs)) = ListN xs
+tail _ = impossible
+
+-- | Get the list with the last element missing
+init :: (1 <= n) => ListN n a -> ListN (n-1) a
+init (ListN l) = ListN $ Data.List.init l
+
+-- | Take m elements from the beggining of the list.
+--
+-- The number of elements need to be less or equal to the list in argument
+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 elements from a list keeping the m remaining elements
+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)
+
+-- | Split a list into two, returning 2 lists
+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)
+
+-- | Get the i'th elements
+--
+-- This only works with TypeApplication:
+--
+-- > indexStatic @1 (toListN_ [1,2,3] :: ListN 3 Int)
+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))
+
+-- | Get the i'the element
+index :: ListN n ty -> Offset ty -> ty
+index (ListN l) ofs = l !! ofs
+
+-- | Update the value in a list at a specific location
+updateAt :: forall n a
+         .  Offset a
+         -> (a -> a)
+         -> ListN n a
+         -> ListN n a
+updateAt o f (ListN l) = ListN (doUpdate 0 l)
+  where doUpdate _ []     = []
+        doUpdate i (x:xs)
+            | i == o      = f x : xs
+            | otherwise   = x : doUpdate (i+1) xs
+
+-- | Map all elements in a list
+map :: (a -> b) -> ListN n a -> ListN n b
+map f (ListN l) = ListN (Prelude.map f l)
+
+-- | Map all elements in a list with an additional index
+mapi :: (Natural -> a -> b) -> ListN n a -> ListN n b
+mapi f (ListN l) = ListN . loop 0 $ l
+  where loop _ []     = []
+        loop i (x:xs) = f i x : loop (i+1) xs
+
+-- | Fold all elements from left
+foldl :: (b -> a -> b) -> b -> ListN n a -> b
+foldl f acc (ListN l) = Prelude.foldl f acc l
+
+-- | Fold all elements from left strictly
+foldl' :: (b -> a -> b) -> b -> ListN n a -> b
+foldl' f acc (ListN l) = Data.List.foldl' f acc l
+
+-- | Fold all elements from left strictly with a first element
+-- as the accumulator
+foldl1' :: (1 <= n) => (a -> a -> a) -> ListN n a -> a
+foldl1' f (ListN l) = Data.List.foldl1' f l
+
+-- | Fold all elements from right
+foldr :: (a -> b -> b) -> b -> ListN n a -> b
+foldr f acc (ListN l) = Prelude.foldr f acc l
+
+-- | Fold all elements from right assuming at least one element is in the list.
+foldr1 :: (1 <= n) => (a -> a -> a) -> ListN n a -> a
+foldr1 f (ListN l) = Prelude.foldr1 f l
+
+-- | 'scanl' is similar to 'foldl', but returns a list of successive
+-- reduced values from the left
+--
+-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+scanl' :: (b -> a -> b) -> b -> ListN n a -> ListN (n+1) b
+scanl' f initialAcc (ListN start) = ListN (go initialAcc start)
+  where
+    go !acc l = acc : case l of
+                        []     -> []
+                        (x:xs) -> go (f acc x) xs
+
+-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:
+--
+-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+scanl1' :: (a -> a -> a) -> ListN n a -> ListN n a
+scanl1' f (ListN l) = case l of
+                        []     -> ListN []
+                        (x:xs) -> ListN $ Data.List.scanl' f x xs
+
+-- | Reverse a list
+reverse :: ListN n a -> ListN n a
+reverse (ListN l) = ListN (Prelude.reverse l)
+
+-- | Zip 2 lists of the same size, returning a new list of
+-- the tuple of each elements
+zip :: ListN n a -> ListN n b -> ListN n (a,b)
+zip (ListN l1) (ListN l2) = ListN (Prelude.zip l1 l2)
+
+-- | Unzip a list of tuple, to 2 List of the deconstructed tuples
+unzip :: ListN n (a,b) -> (ListN n a, ListN n b)
+unzip l = (map fst l, map snd l)
+
+-- | Zip 3 lists of the same size
+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
+
+-- | Zip 4 lists of the same size
+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
+
+-- | Zip 5 lists of the same size
+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
+
+-- | Zip 2 lists using a function
+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
+
+-- | Zip 3 lists using a function
+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
+
+-- | Zip 4 lists using a function
+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
+
+-- | Zip 5 lists using a function
+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

bundled/Basement/Sized/UVect.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# 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)

bundled/Basement/Sized/Vect.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# 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)