circular 0.1.1 → 0.2.0

raw patch · 7 files changed

+295/−353 lines, 7 filesdep +primitivesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: primitive

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−3
• README.md +21/−13
• Setup.hs +1/−0
• bench/Bench.hs +43/−25
• circular.cabal +6/−8
• src/Data/Stack/Circular.hs +156/−234
• test/Data/Stack/CircularSpec.hs +59/−70

@@ -2,12 +2,18 @@ # Changelog for circular  +## Unreleased changes+++## 0.2.0++-   Complete rewrite using mutable vectors. A monadic interface is required now,+    but it is much cleaner in every other sense.++ ## 0.1.1  -   Remove `mean`. -   Add benchmark. -   Many small improvements.---## Unreleased changes 

@@ -3,24 +3,32 @@  <p align="center"><img src="https://travis-ci.org/dschrempf/circular.svg?branch=master"/></p> -Circular fixed-sized stacks.+Circular stacks of fixed size. -Circular stacks with fxed maximum size are just normal vectors with a-pointer to the last element. They are useful because+Circular stacks are just normal vectors with a pointer to the last element. --   memory usage is constant--   they are fast, especially when summary statistics need to be-    computed across the stack (use `unsafePush`, if possible)--   they can be saved, and restored using JSON format+Circular stacks may not be what you need because: -When the stack is full, new, pushed elements replace the oldest (deepest)-elements on the stack. Complex circular behavior can arise when pushes and pops-are mixed. QuickCheck and unit tests with HSpec give promising results &#x2014; have-a look yourself.+-   You need all values at a later time anyways.+-   You don't want a monadic work flow, because circular stacks use mutable+    vectors. +Circular stacks are useful to you because:++-   They have a fixed size and consequently have constant memory usage. Constant+    memory usage is important if values are gathered continuously but only a+    specific number of values is needed at a later time.+-   They are fast, especially when summary statistics need to be computed across+    the stack.++Elements pushed on a circular stack replace the oldest (deepest) elements on the+stack. QuickCheck and unit tests with HSpec give promising results &#x2014; have a+look yourself.+ I use circular stacks, for example, as the data type for traces of Markov-chains.+chains. In this case, lists cannot be used reliably, because the space+requirement increases linearly with the chain length.  `Circular` is actively developed and functions may be removed, renamed, or-changed. New ideas are welcome!+changed. Ideas are welcome! 

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -10,45 +10,63 @@ -- -- Creation date: Sat Jun 20 21:12:38 2020. module Main-  ( main+  ( main,   ) where +import Control.Monad.ST import Criterion.Main-import qualified Data.Stack.Circular as S-import qualified Data.Vector.Unboxed as U+import Data.Foldable+import qualified Data.Stack.Circular as C import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U  -- When using foldl or foldl', list is much slower than cstack. -list ::  Int -> Int-list l = sum $ take 1000 $ foldl (flip (:)) [] [0..l]--cstackV ::  Int -> Int-cstackV l = S.sum $ foldl (flip S.unsafePush) (S.unsafeEmpty 1000 :: S.CStack V.Vector Int) [0..l]--cstackU ::  Int -> Int-cstackU l = S.sum $ foldl (flip S.unsafePush) (S.unsafeEmpty 1000 :: S.CStack U.Vector Int) [0..l]---- When using foldr, cstack is slower by far. This is because of the--- lazyness. However, for stacks, by definition, the last added elements are--- of interest.---- -- The safe operations are very slow.+listFoldL :: Int -> Int+listFoldL l = sum $ take 1000 $ foldl (flip (:)) [] [0 .. l] --- cstackVSafe ::  Int -> Int--- cstackVSafe l = S.sum $ foldl (flip S.push) (S.empty 1000 :: S.CStack V.Vector Int) [0..l]+cstackV :: Int -> Int+cstackV l = runST $ do+  c <- C.replicate 1000 0 :: ST s (C.MStack V.Vector s Int)+  c' <- foldlM (flip C.push) c [0 .. l]+  C.sum c' --- cstackUSafe ::  Int -> Int--- cstackUSafe l = S.sum $ foldl (flip S.push) (S.empty 1000 :: S.CStack U.Vector Int) [0..l]+cstackU :: Int -> Int+cstackU l = runST $ do+  c <- C.replicate 1000 0 :: ST s (C.MStack U.Vector s Int)+  c' <- foldlM (flip C.push) c [0 .. l]+  C.sum c' +-- When using foldr, cstack is slower by far. This is because list are lazy.  main :: IO () main = do   let l = 1000000 :: Int-  print $ list l+  print $ listFoldL l   print $ cstackU l   defaultMain-    [ bench "list, foldl" $ whnf list l-    , bench "cstack, foldl" $ whnf cstackV l-    , bench "cstack unboxed, foldl" $ whnf cstackU l ]+    [ bench "list, foldl" $ whnf listFoldL l,+      bench "cstack, foldl" $ whnf cstackV l,+      bench "cstack unboxed, foldl" $ whnf cstackU l+    ]++-- benchmarking list, foldl+-- time                 196.5 ms   (169.7 ms .. 219.9 ms)+--                      0.983 R²   (0.933 R² .. 1.000 R²)+-- mean                 213.9 ms   (197.8 ms .. 238.8 ms)+-- std dev              25.51 ms   (10.44 ms .. 37.57 ms)+-- variance introduced by outliers: 31% (moderately inflated)++-- benchmarking cstack, foldl+-- time                 18.65 ms   (18.11 ms .. 19.24 ms)+--                      0.993 R²   (0.983 R² .. 0.999 R²)+-- mean                 18.46 ms   (18.13 ms .. 18.99 ms)+-- std dev              979.7 μs   (565.1 μs .. 1.446 ms)+-- variance introduced by outliers: 21% (moderately inflated)++-- benchmarking cstack unboxed, foldl+-- time                 13.97 ms   (13.91 ms .. 14.05 ms)+--                      1.000 R²   (1.000 R² .. 1.000 R²)+-- mean                 13.98 ms   (13.95 ms .. 14.02 ms)+-- std dev              86.51 μs   (61.56 μs .. 120.9 μs)

@@ -1,13 +1,8 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.34.2.------ see: https://github.com/sol/hpack-+cabal-version:  1.12 name:           circular-version:        0.1.1+version:        0.2.0 synopsis:       Circular fixed-sized mutable vectors-description:    Please see the README on GitHub at <https://github.com/dschrempf/circular#readme>+description:    Please see the README at <https://github.com/dschrempf/circular#readme> category:       Math, Data Structures homepage:       https://github.com/dschrempf/circular#readme bug-reports:    https://github.com/dschrempf/circular/issues@@ -36,6 +31,7 @@   build-depends:       aeson     , base >=4.7 && <5+    , primitive     , vector   default-language: Haskell2010 @@ -55,6 +51,7 @@     , circular     , hspec     , hspec-discover+    , primitive     , quickcheck-instances     , vector   default-language: Haskell2010@@ -72,5 +69,6 @@     , base >=4.7 && <5     , circular     , criterion+    , primitive     , vector   default-language: Haskell2010

@@ -1,6 +1,8 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}  -- | -- Module      :  Data.Stack.Circular@@ -13,299 +15,219 @@ -- Portability :  portable -- -- Creation date: Thu Jun 18 10:00:28 2020.+--+-- Construction of mutable circular stacks is done with 'replicate' and subsequent+-- 'push'es, or with 'fromVector'. Use the data constructors for 'MStack' and+-- 'Stack' only if you know what you are doing.+--+-- When denoting the asymptotic runtime of functions, @n@ refers to the circular+-- stack size. module Data.Stack.Circular-  ( -- * Boxed circular stacks-    CStack (..),+  ( -- * Circular stacks+    MStack (..),+    Stack (..),      -- * Construction-    empty,-    unsafeEmpty,+    replicate,      -- * Conversion-    toVector,-    toVectorN,-    unsafeToVectorN,     fromVector,-    unsafeFromVector,+    toVector,+    take,+    thaw,+    freeze,      -- * Accessors     get,     pop,     push,-    unsafePush,-    reset, -    -- * Queries-    isFull,+    -- * Folds -    -- * Folding-    ---    -- Here all fold functions should be provided, but I am too lazy. Instead,-    -- let's just provide some optimized functions to compute summary statistics-    -- across all values on the stack.-    ---    -- For reasons of efficiency, __commutativity__ of the combining function is-    -- __assumed__ for fold-like functions provided in this section! That is,-    -- the order of elements of the stack must not matter.+    -- | __Commutativity__ of the combining function is __assumed__ for+    -- fold-like functions provided in this module, that is, the order of+    -- elements of the stack must not matter!     foldl,-    foldl',-    foldl1',     sum,     product,   ) where -import Control.Monad.ST+import Control.Monad.Primitive import Data.Aeson-import Data.Aeson.Types-import qualified Data.Vector.Generic as V-import Data.Vector.Generic (Vector)-import qualified Data.Vector.Generic.Mutable as M-import Prelude hiding (foldl, product, sum)+import Data.Aeson.TH+import qualified Data.Foldable as F+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VM+import Prelude hiding (foldl, product, replicate, sum, take) --- | Circular stacks with fxed maximum size are just normal vectors with a+-- | Mutable circular stacks with fixed size are just mutable vectors with a -- pointer to the last element.------ Construction of 'CStack's is done with 'empty' and subsequent 'push'es, or--- the provided type conversion functions so that the index and bounds are--- updated and checked consistently. The data constructor 'CStack' is exported--- only to enable creation of orphan instances such as Arbitrary (QuickCheck).------ When denoting the efficiency of the functions @m@ refers to the current size--- of the stack, and @n@ to the maximum size.-data CStack v a = CStack-  { stack :: v a,-    index :: !Int,-    curSize :: !Int+data MStack v s a = MStack+  { mStack :: VG.Mutable v s a,+    mIndex :: !Int   } -instance (Eq (v a), Vector v a) => Eq (CStack v a) where-  (CStack v1 i1 m1) == (CStack v2 i2 m2) = (v1 == v2) && (i1 == i2) && (m1 == m2)--instance (Show (v a), Vector v a) => Show (CStack v a) where-  show c@(CStack _ i m) = "CStack {" ++ show (toVector c) ++ ", " ++ show i ++ ", " ++ show m ++ "}"+-- | Immutable circular stack; useful, for example, to save, or restore a+-- mutable circular stack.+data Stack v a = Stack+  { iStack :: v a,+    iIndex :: !Int+  }+  deriving (Eq, Read, Show) --- | We have @c /= FromJSON $ ToJSON c@, but the elements on the stack and their--- order are correctly saved and restored.-instance (ToJSON a, ToJSON (v a), Vector v a) => ToJSON (CStack v a) where-  toJSON c = object ["stack" .= toVector c, "maxSize" .= n]-    where-      n = V.length $ stack c-  toEncoding c = pairs ("stack" .= toVector c <> "maxSize" .= n)-    where-      n = V.length $ stack c+$(return []) -instance (FromJSON a, FromJSON (v a), Vector v a) => FromJSON (CStack v a) where-  parseJSON = withObject "CStack" fromObject+instance (FromJSON (v a)) => FromJSON (Stack v a) where+  parseJSON = $(mkParseJSON defaultOptions ''Stack) -fromObject :: forall v a. (FromJSON (v a), Vector v a) => Object -> Parser (CStack v a)-fromObject o = do-  v <- o .: "stack" :: Parser (v a)-  n <- o .: "maxSize" :: Parser Int-  let c = empty n-  pure $ V.foldr' unsafePush c v+instance (ToJSON (v a)) => ToJSON (Stack v a) where+  toJSON = $(mkToJSON defaultOptions ''Stack)+  toEncoding = $(mkToEncoding defaultOptions ''Stack) --- Calculate the start index of the stack.+-- | A circular stack of given size with the same element replicated. ----- (startIndex + m - 1) `mod` n = i-startIndex :: Int -> Int -> Int -> Int-startIndex i m n-  | m == 0 = error "startIndex: empty stack"-  | m <= i + 1 = i + 1 - m-  | otherwise = i + 1 - m + n---- -- Do not check for empty stack.--- unsafeStartIndex :: Int -> Int -> Int -> Int--- unsafeStartIndex i m n---   | m <= i + 1 = i + 1 - m---   | otherwise = i + 1 - m + n---- | A circular stack without an element but of a given maximum size. At this--- state, it is not very useful :). O(n).-empty :: Vector v a => Int -> CStack v a-empty n-  | n <= 0 = error "empty: maximum size must be 1 or larger"-  | otherwise = CStack (V.create $ M.unsafeNew n) 0 0+-- Call 'error' if the maximum size is zero or negative.+--+-- O(n).+replicate :: (VG.Vector v a, PrimMonad m) => Int -> a -> m (MStack v (PrimState m) a)+replicate n x+  | n <= 0 = error "empty: maximum size must be one or larger"+  | otherwise = do+    v <- VM.replicate n x+    return $ MStack v 0 --- | See 'empty'; do no check that length is strictly positive.-unsafeEmpty :: Vector v a => Int -> CStack v a-unsafeEmpty n = CStack (V.create $ M.unsafeNew n) 0 0+-- | Convert a vector to a circular stack with size being equal to the length of+-- the vector. The first element of the vector is the deepest (oldest) element+-- of the stack, the last element of the vector is the current (newest) element+-- of the stack.+--+-- The vector must be non-empty.+--+-- O(n).+fromVector :: (VG.Vector v a, PrimMonad m) => v a -> m (MStack v (PrimState m) a)+fromVector v+  | n == 0 = error "fromVector: empty vector"+  | otherwise = do+    mv <- VG.thaw v+    return $ MStack mv (n - 1)+  where+    n = VG.length v  -- | Convert a circular stack to a vector. The first element of the returned -- vector is the deepest (oldest) element of the stack, the last element of the -- returned vector is the current (newest) element of the stack. ----- This is a relatively expensive operation. O(m).-toVector :: Vector v a => CStack v a -> v a-toVector (CStack v i m)-  | m == 0 = V.empty-  | i' + m <= n = V.unsafeSlice i' m v-  | otherwise = V.unsafeDrop i' v V.++ V.unsafeTake (i + 1) v-  where-    n = V.length v-    i' = startIndex i m n+-- O(n).+toVector :: VG.Vector v a => Stack v a -> v a+toVector (Stack v i) = VG.unsafeDrop (i + 1) v VG.++ VG.unsafeTake (i + 1) v --- | Convert the last N elements of a circular stack to a vector. The first+-- | Convert the last k elements of a circular stack to a vector. The first -- element of the returned vector is the deepest (oldest) element of the stack, -- the last element of the returned vector is the current (newest) element of -- the stack. ----- The size of the stack must be larger than N.+-- The size of the stack must be larger than k. ----- This is a relatively expensive operation. O(N).-toVectorN :: Vector v a => Int -> CStack v a -> v a-toVectorN k (CStack v i m)-  | k < 0 = error "toVectorN: negative N"-  | k > m = error "toVectorN: stack too small"-  | k == 0 = V.empty-  | i' + k <= n = V.unsafeSlice i' k v-  | otherwise = V.unsafeDrop i' v V.++ V.unsafeTake (i + 1) v-  where-    n = V.length v-    i' = startIndex i k n---- | See 'toVectorN' but do not check that N is positive.-unsafeToVectorN :: Vector v a => Int -> CStack v a -> v a-unsafeToVectorN k (CStack v i m)-  | k > m = error "toVectorN: stack too small"-  | k == 0 = V.empty-  | i' + k <= n = V.unsafeSlice i' k v-  | otherwise = V.unsafeDrop i' v V.++ V.unsafeTake (i + 1) v+-- O(k).+take :: (VG.Vector v a, PrimMonad m) => Int -> MStack v (PrimState m) a -> m (v a)+take k (MStack v i)+  | k < 0 = error "toVectorN: negative k"+  | k > n = error "toVectorN: circular stack too small"+  | k == 0 = return VG.empty+  | i0 == 0 = VG.freeze $ VM.unsafeTake k v+  | i0 + k <= n = VG.freeze $ VM.unsafeSlice i0 k v+  | otherwise = do+    l <- VG.freeze (VM.unsafeDrop (i + 1) v)+    r <- VG.freeze (VM.unsafeTake k' v)+    return $ l VG.++ r   where-    n = V.length v-    i' = startIndex i k n+    n = VM.length v+    -- Starting index.+    i0 = (i + 1) `mod` n+    -- Number of elements already taken from the starting index to the end of the vector.+    dk = n - i0+    -- Number of elements we still have to take.+    k' = k - dk --- | Convert a vector to a circular stack. The first element of the vector is--- the deepest (oldest) element of the stack, the last element of the vector is--- the current (newest) element of the stack. O(n).+-- | Conversion from immutable to mutable circular stack. ----- The vector must be non-empty.-fromVector :: Vector v a => v a -> CStack v a-fromVector v-  | V.null v = error "fromVector: empty vector"-  | otherwise = CStack v (n - 1) n-  where-    n = V.length v---- | See 'fromVector' but do not check for empty vector.-unsafeFromVector :: Vector v a => v a -> CStack v a-unsafeFromVector v = CStack v (n - 1) n-  where-    n = V.length v+-- O(n).+thaw :: (VG.Vector v a, PrimMonad m) => Stack v a -> m (MStack v (PrimState m) a)+thaw (Stack v i) = do+  mv <- VG.thaw v+  return $ MStack mv i --- | Get the last element without changing the stack. O(1).-get :: Vector v a => CStack v a -> a-get (CStack v i _) = V.unsafeIndex v i-{-# INLINE get #-}+-- | Conversion from mutable to immutable circular stack.+--+-- O(n).+freeze :: (VG.Vector v a, PrimMonad m) => MStack v (PrimState m) a -> m (Stack v a)+freeze (MStack mv i) = do+  v <- VG.freeze mv+  return $ Stack v i  -- Select the previous element without changing the stack.-previous :: Vector v a => CStack v a -> CStack v a-previous (CStack v i m)-  | m == 0 = error "previous: empty stack"-  | i == 0 = CStack v (n - 1) (m - 1)-  | otherwise = CStack v (i - 1) (m - 1)+previous :: VG.Vector v a => MStack v s a -> MStack v s a+previous (MStack v i) = MStack v i'   where-    n = V.length v+    j = i - 1+    i' = if j < 0 then VM.length v - 1 else j --- | Get the last element and remove it from the stack. O(1).+-- | Get the last element without changing the stack. ----- The stack must be non-empty.-pop :: Vector v a => CStack v a -> (a, CStack v a)-pop c = (get c, previous c)-{-# INLINE pop #-}+-- O(1).+get :: (VG.Vector v a, PrimMonad m) => MStack v (PrimState m) a -> m a+get (MStack v i) = VM.unsafeRead v i+{-# INLINE get #-} --- Replace an element in a vector.-set :: Vector v a => Int -> a -> v a -> v a-set i x = V.modify (\v -> M.write v i x)-{-# INLINE set #-}+-- | Pop the current element from the stack and put the focus on the previous+-- element.+--+-- Be careful: `pop` always succeeds, even if there are actually no more+-- elements on the stack (similar to walking in a circle).+--+-- O(1).+pop :: (VG.Vector v a, PrimMonad m) => MStack v (PrimState m) a -> m (a, MStack v (PrimState m) a)+pop x = do+  val <- get x+  return (val, previous x) --- Replace the last element.-put :: Vector v a => a -> CStack v a -> CStack v a-put x (CStack v i m) = CStack (set i x v) i m+-- Replace the current element.+put :: (VG.Vector v a, PrimMonad m) => a -> MStack v (PrimState m) a -> m (MStack v (PrimState m) a)+put x (MStack v i) = VM.unsafeWrite v i x >> return (MStack v i)  -- Select the next element without changing the stack.-next :: Vector v a => CStack v a -> CStack v a-next (CStack v i m)-  | i == (n - 1) = CStack v 0 (min (m + 1) n)-  | otherwise = CStack v (i + 1) (min (m + 1) n)+next :: VG.Vector v a => MStack v s a -> MStack v s a+next (MStack v i) = MStack v i'   where-    n = V.length v---- | Push an element on the stack. Slow! If possible, use 'unsafePush'. O(n).-push :: Vector v a => a -> CStack v a -> CStack v a-push x c = put x $ next c--unsafeSet :: Vector v a => Int -> a -> v a -> v a-unsafeSet i x v = runST $ do-  mv <- V.unsafeThaw v-  M.unsafeWrite mv i x-  V.unsafeFreeze mv---- Replace the last element. O(1).-unsafePut :: Vector v a => a -> CStack v a -> CStack v a-unsafePut x (CStack v i m) = CStack (unsafeSet i x v) i m+    i' = (i + 1) `mod` VM.length v --- | Push an element on the stack. O(1).+-- | Push an element on the stack. ----- Be careful; the internal vector is mutated! The immutable circular stack may--- not be used after this operation.-unsafePush :: Vector v a => a -> CStack v a -> CStack v a-unsafePush x = unsafePut x . next---- | Reset the stack. O(1).-reset :: CStack v a -> CStack v a-reset (CStack v _ _) = CStack v 0 0---- | Check if the stack is full.-isFull :: Vector v a => CStack v a -> Bool-isFull (CStack v _ m) = V.length v == m---- | Left fold. O(m).-foldl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> CStack v b -> a-foldl f x (CStack v i m)-  | m == n = V.foldl f x v-  | i' + m <= n = V.foldl f x $ V.unsafeSlice i' m v-  | otherwise = V.foldl f (V.foldl f x (V.unsafeDrop i' v)) (V.unsafeTake (i + 1) v)-  where-    n = V.length v-    i' = startIndex i m n+-- O(1).+push :: (VG.Vector v a, PrimMonad m) => a -> MStack v (PrimState m) a -> m (MStack v (PrimState m) a)+push x = put x . next --- | Left fold with strict accumulator. O(m).-foldl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> CStack v b -> a-foldl' f x (CStack v i m)-  | m == n = V.foldl' f x v-  | i' + m <= n = V.foldl' f x $ V.unsafeSlice i' m v-  | otherwise = V.foldl' f (V.foldl' f x (V.unsafeDrop i' v)) (V.unsafeTake (i + 1) v)+-- Left fold over a mutable vector. This is all a little stupid.+foldlMV :: (VM.MVector v b, PrimMonad m) => (a -> b -> a) -> a -> v (PrimState m) b -> m a+foldlMV f x v = F.foldlM (\acc i -> f acc <$> VM.unsafeRead v i) x [0 .. (n -1)]   where-    n = V.length v-    i' = startIndex i m n+    n = VM.length v --- | Left fold on non-empty vectors with strict accumulator. O(m).-foldl1' :: Vector v a => (a -> a -> a) -> CStack v a -> a-foldl1' f (CStack v i m)-  | m == n = V.foldl1' f v-  | i' + m <= n = V.foldl1' f $ V.unsafeSlice i' m v-  | otherwise = f (V.foldl1' f (V.unsafeDrop i' v)) (V.foldl1' f (V.unsafeTake (i + 1) v))-  where-    n = V.length v-    i' = startIndex i m n+-- | Left fold.+--+-- O(n).+foldl :: (VG.Vector v b, PrimMonad m) => (a -> b -> a) -> a -> MStack v (PrimState m) b -> m a+foldl f x (MStack v _) = foldlMV f x v --- | Compute the sum of the elements on the stack. O(m).-sum :: (Num a, Vector v a) => CStack v a -> a-sum (CStack v i m)-  | m == n = V.sum v-  | i' + m <= n = V.sum $ V.unsafeSlice i' m v-  | otherwise = V.sum (V.unsafeDrop i' v) + V.sum (V.unsafeTake (i + 1) v)-  where-    n = V.length v-    i' = startIndex i m n+-- | Compute the sum of the elements on the stack.+--+-- O(n).+sum :: (Num a, VG.Vector v a, PrimMonad m) => MStack v (PrimState m) a -> m a+sum = foldl (+) 0 --- | Compute the product of the elements on the stack. O(m).-product :: (Num a, Vector v a) => CStack v a -> a-product (CStack v i m)-  | m == n = V.product v-  | i' + m <= n = V.product $ V.unsafeSlice i' m v-  | otherwise = V.product (V.unsafeDrop i' v) * V.product (V.unsafeTake (i + 1) v)-  where-    n = V.length v-    i' = startIndex i m n+-- | Compute the product of the elements on the stack.+--+-- O(n).+product :: (Num a, VG.Vector v a, PrimMonad m) => MStack v (PrimState m) a -> m a+product = foldl (*) 1

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}-+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- |@@ -19,102 +19,91 @@ where  import Control.Exception+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST import Data.Aeson-import Data.Stack.Circular as C-import Data.Vector (Vector)-import qualified Data.Vector as V+import qualified Data.Stack.Circular as C+import qualified Data.Vector as VB import Test.Hspec import Test.Hspec.QuickCheck-import Test.QuickCheck hiding (Success, Result)+import Test.QuickCheck hiding (Result, Success) import Test.QuickCheck.Instances.Vector ()-import Prelude hiding (sum, product)+import Prelude hiding (product, sum) -instance Arbitrary (CStack Vector Int) where+instance Arbitrary (C.Stack VB.Vector Int) where   arbitrary = do     s <- getSize-    n <- choose (1, s+1)-    v <- V.fromList <$> vector n-    i <- choose (0, n-1)-    m <- choose (1, n)-    return $ CStack v i m+    n <- choose (1, s + 1)+    v <- VB.fromList <$> vector n+    i <- choose (0, n -1)+    return $ C.Stack v i -se :: CStack Vector Int-se = empty 10+se :: PrimMonad m => m (C.MStack VB.Vector (PrimState m) Int)+se = C.replicate 10 0 -ss :: CStack Vector Int-ss = push 13 se+ss :: PrimMonad m => m (C.MStack VB.Vector (PrimState m) Int)+ss = se >>= C.push 13 -prop_from_to_id :: Vector Int -> Bool-prop_from_to_id v-  | V.length v == 0 = True-  | otherwise = toVector (fromVector v) == v+fromTo :: VB.Vector Int -> VB.Vector Int+fromTo v = C.toVector $ runST $ C.fromVector v >>= C.freeze -prop_pop :: Vector Int -> Bool-prop_pop v-  | V.length v == 0 = True-  | otherwise = toVector (snd $ pop $ fromVector v) == V.init v+prop_from_to_id :: VB.Vector Int -> Bool+prop_from_to_id v+  | VB.length v == 0 = True+  | otherwise = fromTo v == v -prop_push_pop :: Int -> Vector Int -> Bool-prop_push_pop x v-  | V.length v == 0 = True-  | otherwise = toVector (snd $ pop $ push x $ fromVector v) == V.tail v+prop_push_get :: Int -> VB.Vector Int -> Bool+prop_push_get x v+  | VB.length v == 0 = True+  | otherwise = x == runST (C.fromVector v >>= C.push x >>= C.get) -prop_push :: Int -> Vector Int -> Bool+prop_push :: Int -> VB.Vector Int -> Bool prop_push x v-  | V.length v == 0 = True-  | otherwise = toVector (push x $ fromVector v) == V.tail v V.++ V.singleton x+  | VB.length v == 0 = True+  | otherwise =+    C.toVector (runST $ C.fromVector v >>= C.push x >>= C.freeze)+      == VB.tail v VB.++ VB.singleton x -prop_many_pushes :: [Int] -> Vector Int -> Bool+prop_many_pushes :: [Int] -> VB.Vector Int -> Bool prop_many_pushes xs v-  | V.length v == 0 = True-  | length xs <= V.length v = True+  | VB.length v == 0 = True+  | length xs <= VB.length v = True   | otherwise =-    toVector (foldr push (fromVector v) xs)-      == V.fromList (reverse $ take (V.length v) xs)--prop_length :: CStack Vector Int -> Bool-prop_length c = V.length (toVector c) == curSize c--jsonId :: CStack Vector Int -> Result (CStack Vector Int)-jsonId c = fromJSON $ toJSON c--prop_json_sum :: CStack Vector Int -> Bool-prop_json_sum c = (sum <$> jsonId c) == Success (sum c)--prop_json_product :: CStack Vector Int -> Bool-prop_json_product c = (product <$> jsonId c) == Success (product c)+    C.toVector+      ( runST $ do+          ms <- C.fromVector v+          ms' <- foldM (flip C.push) ms xs+          C.freeze ms'+      )+      == sol+  where+    nl = length xs+    nv = VB.length v+    -- That was hard :).+    sol = VB.drop nl v VB.++ VB.fromList (reverse $ take nv $ reverse xs) --- Check current size and max size.-prop_json_misc :: CStack Vector Int -> Bool-prop_json_misc c = ((curSize <$> jsonId c) == Success (curSize c)) &&-                   ((V.length . stack <$> jsonId c) == Success (V.length $ stack c))+prop_json :: C.Stack VB.Vector Int -> Bool+prop_json c = Success c == fromJSON (toJSON c)  spec :: Spec spec = do-  describe "construction" $ it "doesn't choke on weird inputs" $ do-    print ss-    toVector se `shouldBe` V.empty-    toVector (snd $ pop ss) `shouldBe` V.empty+  describe "construction" $+    it "doesn't choke on weird inputs" $ do+      C.toVector (runST $ se >>= C.freeze) `shouldBe` VB.replicate 10 0+      runST (ss >>= C.get) `shouldBe` 13    describe "conversion identities" $ do     it "correctly converts partly filled stacks" $-      toVector ss `shouldBe` V.singleton 13-    prop "toVector . fromVector is identity" (prop_from_to_id :: Vector Int -> Bool)+      C.toVector (runST $ ss >>= C.freeze) `shouldBe` (VB.replicate 9 0 `VB.snoc` 13)+    prop "toVector . fromVector is identity" (prop_from_to_id :: VB.Vector Int -> Bool)    describe "conversion failure" $     it "fails to convert empty vectors" $-      evaluate (fromVector V.empty) `shouldThrow` anyErrorCall+      evaluate (runST $ C.fromVector VB.empty >>= C.freeze) `shouldThrow` anyErrorCall    describe "properties" $ do-    prop "pop" prop_pop     prop "push" prop_push-    prop "push pop" prop_push_pop-    prop "many pushed" prop_many_pushes-    prop "length" prop_length-    prop "json sum" prop_json_sum-    prop "json product" prop_json_product-    prop "json misc" prop_json_misc--  describe "laziness" $-    it "should not conflict with intuition" $-    toVector ss `shouldNotBe` toVector (push 10 ss)+    prop "push_get" prop_push_get+    prop "many pushes" prop_many_pushes+    prop "json" prop_json