packages feed

sequence 0.9.8 → 0.9.9.0

raw patch · 20 files changed

+1035/−264 lines, 20 filesdep +QuickCheckdep +sequencedep +tastydep ~basenew-uploader

Dependencies added: QuickCheck, sequence, tasty, tasty-quickcheck

Dependency ranges changed: base

Files

ChangeLog view
@@ -1,4 +1,20 @@-0.9.8: Fixed bug.+0.9.8.0:+* Fixed incomplete pattern errors for `FastQueue` and `BSeq`.+* Fixed fold order for `BSeq`.+* Added a small test suite.+* Added `Semigroup`, `Monoid`, `Eq`, `Ord`, `Show`, `Show1`,+and `Read` instances for all the sequences.+* Added a `fromList` method.+* Made all method implementations reasonably efficient (to the+extent possible for each structure). The defaults led to some+operations being too slow to allow the test suite to complete.+* Fixed a strictness bug in `viewl` for `FastQueue` that caused its+amortized bounds to degrade under persistence.+* Made folds and traversals for `FastQueue` respect the worst-case+bounds for each element pulled.+* Made `fmap` for `FastQueue` stop mapping over the schedule.+* Arranged for GHC to be able to unpack `FastQueue`, though that+will not immediately improve `FastCatQueue`. 0.9.7: Added binary tree sequence datastructure 0.9.6: Fixed bug in Functor for FastQueue which causes it be not O(1) 0.9.5: Added traversable instances (thanks dolio!)
Data/Sequence/BSeq.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE Rank2Types,GADTs, DataKinds, TypeOperators #-}--- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Sequence.BSeq@@ -11,53 +7,14 @@ -- Stability   :  provisional -- Portability :  portable ----- A sequence, implemented as a binary tree, good performance when used ephemerally+-- A catenable qeueue, implemented as a binary tree,+-- with good amortized performance when used ephemerally. -- -- ------------------------------------------------------------------------------module Data.Sequence.BSeq(module Data.SequenceClass,BSeq)  where-import Control.Applicative (pure, (<*>), (<$>))-import Data.Foldable-import Data.Monoid ((<>))-import Data.Traversable-import Prelude hiding (foldr,foldl)+module Data.Sequence.BSeq+  ( module Data.SequenceClass+  , BSeq+  ) where+import Data.Sequence.BSeq.Internal import Data.SequenceClass--data BSeq a = Empty | Leaf a | Node (BSeq a) (BSeq a)----instance Functor BSeq where-  fmap f = loop where-    loop Empty = Empty-    loop (Leaf x) = Leaf (f x)-    loop (Node l r) = Node (loop l) (loop r)--instance Foldable BSeq where-  foldl f = loop where-    loop i s = case viewl s of-          EmptyL -> i-          h :< t -> loop (f i h) t-  foldr f i s = foldr f i (reverse $ toRevList s)-    where toRevList s = case viewl s of-           EmptyL -> []-           h :< t -> h : toRevList t--instance Traversable BSeq where-  traverse f = loop where-    loop Empty = pure Empty-    loop (Leaf x) = Leaf <$> f x-    loop (Node l r) = Node <$> loop l <*> loop r--instance Sequence BSeq where-  empty     = Empty-  singleton = Leaf-  (><)      = Node-  viewl Empty               = EmptyL-  viewl (Leaf x)            = x :< Empty-  viewl (Node (Node l r) z) = viewl (Node l (Node r z))-  viewl (Node Empty r)      = viewl r-  viewl (Node (Leaf x) r)   = x :< r---
+ Data/Sequence/BSeq/Internal.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types,GADTs, DataKinds, TypeOperators #-}+{-# LANGUAGE DeriveTraversable #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+#endif++++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Sequence.BSeq+-- Copyright   :  (c) Atze van der Ploeg 2014+-- License     :  BSD-style+-- Maintainer  :  atzeus@gmail.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A catenable qeueue, implemented as a binary tree,+-- with good amortized performance when used ephemerally.+--+--+-----------------------------------------------------------------------------+module Data.Sequence.BSeq.Internal (BSeq (..))  where+import Control.Applicative hiding (empty)+import Data.Foldable+import Data.Monoid (Monoid (..), (<>))+import Data.Traversable+import qualified Text.Read as TR+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Semigroup+import Data.Functor.Classes (Show1 (..))+#endif+import Data.Function (on)+import Prelude hiding (foldr,foldl)+import Data.SequenceClass++-- | A catenable queue intended for ephemeral use.+data BSeq a = Empty | Leaf a | Node (BSeq a) (BSeq a)+-- Invariant: Neither child of a Node may be Empty.+  deriving (Functor, Traversable)++instance Foldable BSeq where+  foldMap _ Empty = mempty+  foldMap f (Leaf a) = f a+  foldMap f (Node l r) = foldMap f l `mappend` foldMap f r++  foldr _ n Empty = n+  foldr c n (Leaf a) = c a n+  foldr c n (Node l r) = foldr c (foldr c n r) l++#if MIN_VERSION_base(4,8,0)+  -- This implementation avoids digging into Nodes to see+  -- that they're not empty.+  null Empty = True+  null _ = False+#endif++#if MIN_VERSION_base(4,9,0)+instance Semigroup.Semigroup (BSeq a) where+  (<>) = (><)+#endif+instance Monoid (BSeq a) where+  mempty = empty+#if MIN_VERSION_base(4,9,0)+  mappend = (Semigroup.<>)+#else+  mappend = (><)+#endif++instance Show a => Show (BSeq a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)++#if MIN_VERSION_base(4,9,0)+instance Show1 BSeq where+  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $+        showString "fromList " . shwList (toList xs)+#endif++instance Read a => Read (BSeq a) where+    readPrec = TR.parens $ TR.prec 10 $ do+        TR.Ident "fromList" <- TR.lexP+        xs <- TR.readPrec+        return (fromList xs)++    readListPrec = TR.readListPrecDefault++instance Eq a => Eq (BSeq a) where+  (==) = (==) `on` toList++instance Ord a => Ord (BSeq a) where+  compare = compare `on` toList++instance Sequence BSeq where+  empty     = Empty+  singleton = Leaf+  Empty      >< r = r+  l          >< Empty = l+  Node l r   >< z = Node l (Node r z)+  l@(Leaf _) >< z = Node l z+  viewl Empty         = EmptyL+  viewl (Leaf x)      = x :< Empty+  viewl (Node l r)    = case viewl l of+    EmptyL -> error "Invariant failure"+    x :< l' -> (x :<) $! l' >< r+  viewr Empty = EmptyR+  viewr (Leaf x) = Empty :> x+  viewr (Node l r) = case viewr r of+    EmptyR -> error "Invariant failure"+    r' :> x -> (:> x) $! l >< r'+  fromList [] = Empty+  fromList [x] = Leaf x+  fromList (x : xs) = Node (Leaf x) (fromList xs)
Data/Sequence/FastCatQueue.hs view
@@ -9,7 +9,7 @@ -- Stability   :  provisional -- Portability :  portable ----- A sequence, a catanable queue, with worst case constant time: '><', '|>', '<|' and 'tviewl'.+-- A sequence, a catenable queue, with worst case constant time: '><', '|>', '<|' and 'viewl'. -- ----------------------------------------------------------------------------- module Data.Sequence.FastCatQueue(module Data.SequenceClass, FastTCQueue) where@@ -18,4 +18,5 @@ import Data.Sequence.FastQueue import Data.Sequence.ToCatQueue +-- | A catenable queue. type FastTCQueue =  ToCatQueue FastQueue
Data/Sequence/FastQueue.hs view
@@ -1,72 +1,24 @@-{-# LANGUAGE GADTs, ViewPatterns, TypeOperators #-}-- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Sequence.FastQueue -- Copyright   :  (c) Atze van der Ploeg 2014+--                (c) David Feuer 2021 -- License     :  BSD-style -- Maintainer  :  atzeus@gmail.org -- Stability   :  provisional -- Portability :  portable ----- A sequence, a queue, with worst case constant time: '|>', and 'tviewl'.+-- A queue (actually an output-restricted deque), with worst case constant time:+-- '|>', '<|', and 'viewl'. It has worst case linear time 'viewr' and '><'. -- -- Based on: "Simple and Efficient Purely Functional Queues and Deques", Chris Okasaki, -- Journal of Functional Programming 1995 -- ----------------------------------------------------------------------------- -module Data.Sequence.FastQueue(module Data.SequenceClass, FastQueue) where-import Control.Applicative (pure, (<$>), (<*>))-import Control.Applicative.Backwards+module Data.Sequence.FastQueue +  ( module Data.SequenceClass+  , FastQueue+  ) where import Data.SequenceClass-import Data.Foldable-import Data.Traversable-import Prelude hiding (foldr,foldl)--revAppend l r = rotate l r []--- precondtion : |a| = |f| - (|r| - 1)--- postcondition: |a| = |f| - |r|-rotate :: [a] -> [a]-> [a] -> [a]-rotate []  [y] r = y : r-rotate (x : f) (y : r) a = x : rotate f r (y : a)-rotate f        a     r  = error "Invariant |a| = |f| - (|r| - 1) broken"--data FastQueue a where-  RQ :: ![a] -> ![a] -> ![a] -> FastQueue a--queue :: [a] -> [a] -> [a] -> FastQueue a-queue f r [] = let f' = revAppend f r -                 in RQ f' [] f'-queue f r (h : t) = RQ f r t--instance Functor FastQueue where-  fmap phi q = case viewl q of-     EmptyL -> empty-     h :< t -> phi h <| fmap phi t--instance Foldable FastQueue where-  foldl f = loop where-    loop i s = case viewl s of-          EmptyL -> i-          h :< t -> loop (f i h) t-  foldr f i s = foldr f i (reverse $ toRevList s)-    where toRevList s = case viewl s of-           EmptyL -> []-           h :< t -> h : toRevList t--instance Sequence FastQueue where- empty = RQ [] [] []- singleton x = let c = [x] in queue c [] c- (RQ f r a) |> x = queue f (x : r) a-- viewl (RQ [] [] []) = EmptyL- viewl (RQ (h : t) f a) = h :< queue t f a--instance Traversable FastQueue where-  sequenceA q = case viewl q of-     EmptyL -> pure empty-     h :< t  -> (<|) <$> h <*> sequenceA t-   -+import Data.Sequence.FastQueue.Internal
+ Data/Sequence/FastQueue/Internal.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BangPatterns #-}+++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Sequence.FastQueue+-- Copyright   :  (c) Atze van der Ploeg 2014+--                (c) David Feuer 2021+-- License     :  BSD-style+-- Maintainer  :  atzeus@gmail.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A queue (actually an output-restricted deque), with worst case constant time:+-- '|>', '<|', and 'viewl'. It has worst case linear time 'viewr'. '><' is linear+-- in the length of its second argument.+--+-- Based on: "Simple and Efficient Purely Functional Queues and Deques", Chris Okasaki,+-- Journal of Functional Programming 1995+--+-----------------------------------------------------------------------------++module Data.Sequence.FastQueue.Internal+  ( FastQueue (..)+  , SL (..)+  , appendSL+  , queue+  ) where+import Data.SequenceClass hiding ((:>))+import qualified Data.SequenceClass as SC+import Data.Foldable+import qualified Data.Traversable as T+import Data.Sequence.FastQueue.Internal.Any+import qualified Control.Applicative as A+import Data.Function (on)+import qualified Text.Read as TR+#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes (Show1 (..))+import qualified Data.Semigroup as Semigroup+#endif++#if !MIN_VERSION_base(4,8,0)+import Data.Functor (Functor (..))+import Data.Monoid (Monoid (..))+#endif++infixl 5 :>+-- | A lazy-spined snoc-list. Why lazy-spined? Only because+-- that's better for `fmap`. In theory, strict-spined should+-- be a bit better for everything else, but in practice it+-- makes no measurable difference.+data SL a+  = SNil+  | SL a :> a+  deriving Functor++-- | Append a snoc list to a list.+appendSL :: [a] -> SL a -> [a]+appendSL l r = rotate l r []+-- precondition : |a| = |f| - (|r| - 1)+-- postcondition: |a| = |f| - |r|+rotate :: [a] -> SL a -> [a] -> [a]+rotate [] (SNil :> y) r = y : r+rotate (x : f) (r :> y) a = x : rotate f r (y : a)+rotate _f _a _r  = error "Invariant |a| = |f| - (|r| - 1) broken"++-- | A scheduled Banker's FastQueue, as described by Okasaki.+data FastQueue a = RQ ![a] !(SL a) ![Any]+  deriving Functor+  -- We use 'Any' rather than an existential to allow GHC to unpack+  -- queues if it's so inclined.++queue :: [a] -> SL a -> [Any] -> FastQueue a+queue f r [] =+  let+    f' = appendSL f r+    {-# NOINLINE f' #-}+  in RQ f' SNil (toAnyList f')+queue f r (_h : t) = RQ f r t++instance Sequence FastQueue where+  empty = RQ [] SNil []+  singleton x =+    let+      c = [x]+      {-# NOINLINE c #-}+    in RQ c SNil (toAnyList c)+  RQ f r a |> x = queue f (r :> x) a++  -- We need to extend the schedule to maintain the+  -- data structure invariant.+  x <| RQ f r a = RQ (x : f) r (toAny () : a)++  (><) = foldl' (|>)++  viewl (RQ [] ~SNil ~[]) = EmptyL+  viewl (RQ (h : t) f a) = h :< queue t f a++  -- Sometimes we get lucky and we can snatch the last element+  -- for free. Sometimes we don't, and it costs us O(n) time.+  viewr (RQ f (rs :> r) a) = RQ f rs (toAny () : a) SC.:> r+  viewr (RQ f SNil _) = case viewr f of+    EmptyR -> EmptyR+    f' SC.:> x -> fromList f' SC.:> x++  fromList xs = RQ xs SNil (toAnyList xs)++instance Show a => Show (FastQueue a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)++#if MIN_VERSION_base(4,9,0)+instance Show1 FastQueue where+  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $+        showString "fromList " . shwList (toList xs)+#endif++instance Read a => Read (FastQueue a) where+    readPrec = TR.parens $ TR.prec 10 $ do+        TR.Ident "fromList" <- TR.lexP+        xs <- TR.readPrec+        return (fromList xs)++    readListPrec = TR.readListPrecDefault++instance Eq a => Eq (FastQueue a) where+  (==) = (==) `on` toList++instance Ord a => Ord (FastQueue a) where+  compare = compare `on` toList++-- -----------------+-- Note: folding and traversing+--+-- We define the Foldable and Traversable instances for this type manually+-- rather than deriving them. This is necessary to maintain the *worst case*+-- performance bounds expected for this type. For example, suppose we convert a+-- FastQueue to a list using toList. Then we expect to be able to consume each+-- cons of the resulting list in O(1) time. If we used the derived instance,+-- and had RQ f r a, then once f was exhausted we'd have to pause to reverse r.+-- Note that `traverse` is inherently a bit weird from a performance+-- standpoint, because it delays building the result structure until the end.+-- There's nothing we can do about this; the Applicative constraint on traverse+-- isn't sufficient to build as we go.++instance Foldable FastQueue where+  -- See note: folding and traversing+  foldr c n = \q -> go q+    where+      go q = case viewl q of+        EmptyL -> n+        h :< t -> c h (go t)+#if MIN_VERSION_base(4,6,0)+  foldl' f b0 = \q -> go q b0+    where+      go q !b = case viewl q of+        EmptyL -> b+        h :< t -> go t (f b h)+#endif++#if MIN_VERSION_base(4,8,0)+  null (RQ [] _ _) = True+  null _ = False+#endif++instance T.Traversable FastQueue where+  -- See note: folding and traversing+  traverse f = fmap fromList . go+    where+      go q = case viewl q of+        EmptyL -> A.pure empty+        h :< t  -> A.liftA2 (:) (f h) (go t)++#if MIN_VERSION_base(4,9,0)+instance Semigroup.Semigroup (FastQueue a) where+  (<>) = (><)+#endif+instance Monoid (FastQueue a) where+  mempty = empty+#if MIN_VERSION_base(4,9,0)+  mappend = (Semigroup.<>)+#else+  mappend = (><)+#endif
+ Data/Sequence/FastQueue/Internal/Any.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Trustworthy #-}+#endif+-- We suppress this warning because otherwise GHC complains+-- about the newtype constructor not being used.+#if __GLASGOW_HASKELL__ >= 800+-- This warning doesn't seem to exist before 8.0, by any name.+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+#endif+++-- | It's safe to coerce /to/ 'Any' as long as you don't+-- coerce back. We define our own 'Any' instead of using+-- the one in "GHC.Exts" directly to ensure that this+-- module doesn't clash with one making the opposite+-- assumption. We use a newtype rather than a closed type+-- family with no instances because the latter weren't supported+-- until 8.0.+module Data.Sequence.FastQueue.Internal.Any+  ( Any+  , toAny+  , toAnyList+  ) where++import Unsafe.Coerce+import qualified GHC.Exts as E++newtype Any = Any E.Any++-- | Convert anything to 'Any'.+toAny :: a -> Any+toAny = unsafeCoerce++-- | Convert a list of anything to a list of 'Any'.+toAnyList :: [a] -> [Any]+toAnyList = unsafeCoerce
Data/Sequence/Queue.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE Rank2Types,GADTs, DataKinds, TypeOperators #-}--- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Sequence.Queue@@ -11,7 +7,7 @@ -- Stability   :  provisional -- Portability :  portable ----- A sequence, a queue, with amortized constant time: '|>', and 'tviewl'.+-- A sequence, a queue, with amortized constant time: '|>', and 'viewl'. -- -- A simplified version of Okasaki's implicit recursive -- slowdown queues. @@ -20,91 +16,5 @@ -- ----------------------------------------------------------------------------- module Data.Sequence.Queue(module Data.SequenceClass,Queue)  where-import Control.Applicative (pure, (<*>), (<$>))-import Data.Foldable-import Data.Monoid ((<>))-import Data.Traversable-import Prelude hiding (foldr,foldl)+import Data.Sequence.Queue.Internal import Data.SequenceClass--data P a = a :* a --instance Functor P where-  fmap f (a :* b) = f a :* f b--instance Foldable P where-  foldl f z (a :* b) = f (f z a) b-  foldr f z (a :* b) = f a (f b z)-  foldMap f (a :* b) = f a <> f b--instance Traversable P where-  traverse f (a :* b) = (:*) <$> f a <*> f b--data B a where-  B1 :: a    -> B a-  B2 :: !(P a)  -> B a--instance Functor B where- fmap phi (B1 c) = B1 (phi c)- fmap phi (B2 p) = B2 (fmap phi p)--instance Foldable B where-  foldl f z (B1 x) = f z x-  foldl f z (B2 p) = foldl f z p-  foldr f z (B1 x) = f x z-  foldr f z (B2 p) = foldr f z p-  foldMap f (B1 x) = f x-  foldMap f (B2 p) = foldMap f p--instance Traversable B where-  traverse f (B1 x) = B1 <$> f x-  traverse f (B2 p) = B2 <$> traverse f p--data Queue a  where-  Q0 :: Queue a -  Q1 :: a  -> Queue a-  QN :: !(B a) -> Queue (P a) -> !(B a) -> Queue a--instance Functor Queue where-  fmap f Q0 = Q0-  fmap f (Q1 x) = Q1 (f x)-  fmap f (QN l m r) = QN (fmap f l) (fmap (fmap f) m) (fmap f r)--instance Foldable Queue where-  foldl f = loop where-    loop i s = case viewl s of-          EmptyL -> i-          h :< t -> loop (f i h) t-  foldr f i s = foldr f i (reverse $ toRevList s)-    where toRevList s = case viewl s of-           EmptyL -> []-           h :< t -> h : toRevList t--instance Traversable Queue where-  traverse f Q0 = pure Q0-  traverse f (Q1 x) = Q1 <$> f x-  traverse f (QN b1 q b2) = QN <$> traverse f b1 <*> traverse (traverse f) q <*> traverse f b2--instance Sequence Queue where-  empty = Q0-  singleton = Q1 -  q |> b = case q of-    Q0             -> Q1 b-    Q1 a           -> QN (B1 a) Q0 (B1 b)-    QN l m (B1 a)  -> QN l m (B2 (a :* b)) -    QN l m (B2 r)  -> QN l (m |> r) (B1 b)--  viewl q = case q of-    Q0                    -> EmptyL-    Q1 a                  -> a :< Q0-    QN (B2 (a :* b)) m r  -> a :< QN (B1 b) m r-    QN (B1 a) m r         -> a :< shiftLeft m r-    where  -           shiftLeft q r = case viewl q of-               EmptyL -> buf2queue r-               l :< m -> QN (B2 l) m r-           buf2queue (B1 a)        = Q1 a-           buf2queue(B2 (a :* b))  = QN (B1 a) Q0 (B1 b)---
+ Data/Sequence/Queue/Internal.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types,GADTs, DataKinds, TypeOperators #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Sequence.Queue+-- Copyright   :  (c) Atze van der Ploeg 2014+-- License     :  BSD-style+-- Maintainer  :  atzeus@gmail.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A sequence, a queue, with amortized constant time: '|>', and 'viewl'.+-- It also supports '|>' and 'viewr' in amortized logarithmic time.+--+-- A simplified version of Okasaki's implicit recursive+-- slowdown queues. +-- See purely functional data structures by Chris Okasaki +-- section 8.4: Queues based on implicit recursive slowdown+--+-----------------------------------------------------------------------------+module Data.Sequence.Queue.Internal+  ( Queue (..)+  , P (..)+  , B (..)+  )  where+import Control.Applicative (pure, (<*>), (<$>))+import Data.Foldable+import Data.Monoid (Monoid (..), (<>))+import Data.Traversable+import qualified Text.Read as TR+import Data.Function (on)+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Semigroup+import Data.Functor.Classes (Show1 (..))+#endif++import Prelude hiding (foldr,foldl)+import Data.SequenceClass++data P a = a :* a +  deriving (Functor, Foldable, Traversable)++data B a where+  B1 :: a    -> B a+  B2 :: !(P a)  -> B a++deriving instance Functor B+deriving instance Foldable B+deriving instance Traversable B++-- | A queue.+data Queue a  where+  Q0 :: Queue a +  Q1 :: a  -> Queue a+  QN :: !(B a) -> Queue (P a) -> !(B a) -> Queue a++deriving instance Functor Queue+-- The derived Foldable instance has an optimal null+-- with a good unfolding. No need to fuss around with it.+deriving instance Foldable Queue+deriving instance Traversable Queue++#if MIN_VERSION_base(4,9,0)+instance Semigroup.Semigroup (Queue a) where+  (<>) = (><)+#endif+instance Monoid (Queue a) where+  mempty = empty+#if MIN_VERSION_base(4,9,0)+  mappend = (Semigroup.<>)+#else+  mappend = (><)+#endif++instance Sequence Queue where+  empty = Q0+  singleton = Q1 +  q |> b = case q of+    Q0             -> Q1 b+    Q1 a           -> QN (B1 a) Q0 (B1 b)+    QN l m (B1 a)  -> QN l m (B2 (a :* b))+    QN l m (B2 r)  -> QN l (m |> r) (B1 b)++  a <| q = case q of+    Q0 -> Q1 a+    Q1 b -> QN (B1 a) Q0 (B1 b)+    QN (B1 b) m r -> QN (B2 (a :* b)) m r+    QN (B2 l) m r -> QN (B1 a) (l <| m) r++  (><) = foldl' (|>)++  viewl q0 = case q0 of+    Q0                    -> EmptyL+    Q1 a                  -> a :< Q0+    QN (B2 (a :* b)) m r  -> a :< QN (B1 b) m r+    QN (B1 a) m r         -> a :< shiftLeft m r+    where  +           shiftLeft q r = case viewl q of+               EmptyL -> buf2queue r+               l :< m -> QN (B2 l) m r++  viewr q0 = case q0 of+    Q0 -> EmptyR+    Q1 a -> Q0 :> a+    QN l m (B2 (a :* b)) -> QN l m (B1 a) :> b+    QN l m (B1 a) -> shiftRight l m :> a+    where+      shiftRight l q = case viewr q of+        EmptyR -> buf2queue l+        m :> r -> QN l m (B2 r)++buf2queue :: B a -> Queue a+buf2queue (B1 a)        = Q1 a+buf2queue (B2 (a :* b))  = QN (B1 a) Q0 (B1 b)+{-# INLINE buf2queue #-}++instance Show a => Show (Queue a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)++#if MIN_VERSION_base(4,9,0)+instance Show1 Queue where+  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $+        showString "fromList " . shwList (toList xs)+#endif++instance Read a => Read (Queue a) where+    readPrec = TR.parens $ TR.prec 10 $ do+        TR.Ident "fromList" <- TR.lexP+        xs <- TR.readPrec+        return (fromList xs)++    readListPrec = TR.readListPrecDefault++instance Eq a => Eq (Queue a) where+  (==) = (==) `on` toList++instance Ord a => Ord (Queue a) where+  compare = compare `on` toList+
Data/Sequence/ToCatQueue.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE GADTs #-}--- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Sequence.ToCatQueue@@ -19,46 +15,9 @@ -- ----------------------------------------------------------------------------- -module Data.Sequence.ToCatQueue(module Data.SequenceClass,ToCatQueue) where-import Control.Applicative (pure, (<*>), (<$>))-import Data.Foldable-import Data.Traversable-import Prelude hiding (foldr,foldl)+module Data.Sequence.ToCatQueue+  ( module Data.SequenceClass+  , ToCatQueue+  ) where+import Data.Sequence.ToCatQueue.Internal import Data.SequenceClass---- | The catenable queue type. The first type argument is the --- type of the queue we use (|>)-data ToCatQueue q a where-  C0 :: ToCatQueue q a-  CN :: a -> !(q (ToCatQueue q a)) -> ToCatQueue q a--instance Functor q => Functor (ToCatQueue q) where-  fmap f C0 = C0-  fmap f (CN l m) = CN (f l) (fmap (fmap f) m)--instance Foldable q => Foldable (ToCatQueue q) where-  foldl f z C0 = z-  foldl f z (CN x qs) = foldl (foldl f) (f z x) qs-  foldr f z C0 = z-  foldr f z (CN x qs) = x `f` foldr (\q z -> foldr f z q) z qs--instance Sequence q => Sequence (ToCatQueue q) where- empty       = C0- singleton a = CN a empty- C0        >< ys  = ys- xs        >< C0  = xs- (CN x q)  >< ys  = CN x (q |> ys)-- viewl C0        = EmptyL- viewl (CN h t)  = h :< linkAll t-   where -    linkAll :: Sequence q =>  q (ToCatQueue q a)  -> ToCatQueue q a-    linkAll v = case viewl v of-     EmptyL     -> C0-     CN x q :< t  -> CN x (q `snoc` linkAll t)-    snoc q C0  = q-    snoc q r   = q |> r--instance Traversable q => Traversable (ToCatQueue q) where-  traverse f C0 = pure C0-  traverse f (CN x qs) = CN <$> f x <*> traverse (traverse f) qs
+ Data/Sequence/ToCatQueue/Internal.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+#endif+++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Sequence.ToCatQueue.Internal+-- Copyright   :  (c) Atze van der Ploeg 2013+-- License     :  BSD-style+-- Maintainer  :  atzeus@gmail.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A purely functional catenable queue representation with+-- that turns takes a purely functional queue and turns in it into+-- a catenable queue, i.e. with the same complexity for '><' as for '|>'+-- Based on Purely functional data structures by Chris Okasaki +-- section 7.2: Catenable lists+--+-----------------------------------------------------------------------------++module Data.Sequence.ToCatQueue.Internal+  ( ToCatQueue (..)+  ) where+import Control.Applicative hiding (empty)+import Data.Foldable+import Data.Traversable+import Data.Monoid (Monoid (..))+import qualified Text.Read as TR+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Semigroup+import Data.Functor.Classes (Show1 (..))+#endif+import Data.Function (on)+import Prelude hiding (foldr,foldl)+import Data.SequenceClass++-- | The catenable queue type. The first type argument is the +-- type of the queue we use (|>)+data ToCatQueue q a where+  -- Invariant: no element of the queue of queues may+  -- be empty.+  C0 :: ToCatQueue q a+  CN :: a -> !(q (ToCatQueue q a)) -> ToCatQueue q a++deriving instance Functor q => Functor (ToCatQueue q)+deriving instance Foldable q => Foldable (ToCatQueue q)+deriving instance Traversable q => Traversable (ToCatQueue q)++instance (Show a, Foldable q) => Show (ToCatQueue q a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)++#if MIN_VERSION_base(4,9,0)+instance Foldable q => Show1 (ToCatQueue q) where+  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $+        showString "fromList " . shwList (toList xs)+#endif++instance (Sequence q, Read a) => Read (ToCatQueue q a) where+    readPrec = TR.parens $ TR.prec 10 $ do+        TR.Ident "fromList" <- TR.lexP+        xs <- TR.readPrec+        return (fromList xs)++    readListPrec = TR.readListPrecDefault++instance (Foldable q, Eq a) => Eq (ToCatQueue q a) where+  (==) = (==) `on` toList++instance (Foldable q, Ord a) => Ord (ToCatQueue q a) where+  compare = compare `on` toList++instance Sequence q => Sequence (ToCatQueue q) where+ empty       = C0+ singleton a = CN a empty+ C0        >< ys  = ys+ xs        >< C0  = xs+ (CN x q)  >< ys  = CN x (q |> ys)++ viewl C0        = EmptyL+ viewl (CN x0 q0)  = x0 :< case viewl q0 of+   EmptyL -> C0+   t :< q'  -> linkAll t q'+   where+   linkAll :: ToCatQueue q a -> q (ToCatQueue q a) -> ToCatQueue q a+   linkAll t@(CN x q) q' = case viewl q' of+     EmptyL -> t+     h :< t' -> CN x (q |> linkAll h t')+   linkAll C0 _ = error "Invariant failure"++ viewr = foldl' go EmptyR+   where+     go EmptyR y = empty :> y+     go (xs :> x) y = xs' :> y+       where+         !xs' = xs |> x++#if MIN_VERSION_base(4,9,0)+instance Sequence q => Semigroup.Semigroup (ToCatQueue q a) where+  (<>) = (><)+#endif+instance Sequence q => Monoid (ToCatQueue q a) where+  mempty = empty+#if MIN_VERSION_base(4,9,0)+  mappend = (Semigroup.<>)+#else+  mappend = (><)+#endif
Data/SequenceClass.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances, GADTs,TypeSynonymInstances,FlexibleInstances,Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}   @@ -18,33 +20,71 @@ module Data.SequenceClass(Sequence(..), ViewL(..), ViewR(..)) where  import Data.Monoid-import Data.Foldable+import Data.Foldable (foldl')+import qualified Data.Foldable as F import qualified Data.Sequence as S  infixr 5 <| infixl 5 |> infix 5 ><+infixl 9 :<+infixr 9 :> {- | A type class for (finite) sequences  -Minimal complete defention: 'empty' and 'singleton' and ('viewl' or 'viewr') and ('><' or '|>' or '<|') -Instances should satisfy the following laws:+Instances should be /free monoids/+(<http://comonad.com/reader/2015/free-monoids-in-haskell/ ignoring issues with infinite and partially defined structures>),+just like lists, with @singleton@ as the canonical injection and @foldMap@+factoring functions.  In particular, they should satisfy the following laws: -Monoid laws:+@Semigroup@ and @Monoid@ laws: +> (><) == (Data.Semigroup.<>)+> empty == mempty++In particular, this requires that+ > empty >< x == x > x >< empty == x > (x >< y) >< z = x >< (y >< z) +@FoldMap@/@singleton@ laws:++For any 'Monoid' @m@ and any function @f :: c -> m@,++1. @'foldMap' f@ is a monoid morphism:++    * @'foldMap' f 'mempty' = 'mempty'@+    * @'foldMap' f (m '<>' n) = 'foldMap' f m <> 'foldMap' f n@++2. 'foldMap' undoes 'singleton':++    @'foldMap' f . 'singleton' = f@+ Observation laws:  > viewl (singleton e >< s) == e :< s > viewl empty == EmptyL -The behaviour of '<|','|>', and 'viewr' is implied by the above laws and their default definitions.+The behaviour of '<|','|>', and 'viewr' is implied by the above laws and their+default definitions.++Warning: the default definitions are typically awful. Check them carefully+before relying on them. In particular, they may well work in @O(n^2)@ time (or+worse?) when even definitions that convert to and from lists would work in+@O(n)@ time. Exceptions: for sequences with constant time concatenation, the+defaults for '<|' and '|>' are okay. For sequences with constant time '|>',+the default for 'fromList' is okay. -}-class (Functor s, Foldable s) => Sequence s where+class (F.Foldable s, Functor s) => Sequence s where +  {-# MINIMAL+    empty,+    singleton,+    (viewl | viewr),+    ((><) | (|>) | (<|))+    #-}+   empty     :: s c    singleton :: c  -> s c    -- | Append two sequences@@ -77,6 +117,13 @@   --   (<|)       :: c  -> s c -> s c   +  -- | Convert a list to a sequence+  --+  -- Default definition:+  --+  -- > fromList = foldl' (|>) empty+  fromList :: [c] -> s c+   l |> r = l >< singleton r   l <| r = singleton l >< r   l >< r = case viewl l of@@ -95,14 +142,22 @@         EmptyR -> empty   :> h         p :> l   -> (h <| p) :> l +  fromList = foldl' (|>) empty++-- | A view of the left end of a 'Sequence'. data ViewL s c where    EmptyL  :: ViewL s c -   (:<)    :: c  -> s c  -> ViewL s c +   (:<)    :: c -> s c -> ViewL s c -data ViewR s c  where+deriving instance (Show c, Show (s c)) => Show (ViewL s c)++-- | A view of the right end of a 'Sequence'.+data ViewR s c where    EmptyR  :: ViewR s c -   (:>)     :: s c -> c -> ViewR s c +   (:>)    :: s c -> c -> ViewR s c +deriving instance (Show c, Show (s c)) => Show (ViewR s c)+   instance Sequence S.Seq where  empty = S.empty@@ -116,13 +171,25 @@  viewr s = case S.viewr s of    S.EmptyR -> EmptyR    t S.:> h -> t :> h+ fromList = S.fromList  instance Sequence [] where   empty = []   singleton x = [x]   (<|) = (:)+  xs |> x = xs ++ [x]+  (><) = (++)   viewl [] = EmptyL   viewl (h : t) = h :< t  --+  -- This definition is entirely strict. I'm not sure whether there's+  -- a real benefit to making it lazy or not.+  -- NOTE: if we *do* make it lazy, then the definition of viewr+  -- for FastQueue will have to be adjusted to keep its bounds+  -- worst case.+  viewr [] = EmptyR+  viewr (x : xs) = case go x xs of (start, end) -> start :> end+    where+      go y [] = ([], y)+      go y (z : zs) = case go z zs of (start, end) -> (y : start, end)+  fromList = id
+ fake-test/Test.hs view
@@ -0,0 +1,5 @@+-- This fake test module is just a workaround so that+-- haskell-ci doesn't fail when the GHC version is too+-- old to build the test suite.+main :: IO ()+main = return ()
sequence.cabal view
@@ -1,21 +1,62 @@ Name:                sequence-Version:             0.9.8-Synopsis:	         A type class for sequences and various sequence data structures.-Description:         A type class for sequences and various sequence data structures.+Version:             0.9.9.0+Synopsis:	     A type class for sequences and various sequence data structures.+Description:         A type class for finite sequences along with several data structures+                     that implement it. License:             BSD3 License-file:        LICENSE Author:              Atze van der Ploeg Maintainer:          atzeus@gmail.com Homepage:            https://github.com/atzeus/sequence Build-Type:          Simple-Cabal-Version:       >=1.6+Cabal-Version:       2.0 Data-files:          ChangeLog Category:            Data, Data Structures Tested-With:         GHC==7.6.3 Library-  Build-Depends: base >= 2 && <= 6, containers, transformers-  Exposed-modules: Data.SequenceClass,Data.Sequence.BSeq, Data.Sequence.Queue, Data.Sequence.FastQueue, Data.Sequence.FastCatQueue,  Data.Sequence.ToCatQueue-  Extensions:	+  default-language: Haskell2010+  ghc-options: -Wall -fno-warn-unused-imports+  build-depends: base >= 2 && <= 6, containers, transformers+  exposed-modules:+      Data.SequenceClass+    , Data.Sequence.BSeq+    , Data.Sequence.BSeq.Internal+    , Data.Sequence.Queue+    , Data.Sequence.Queue.Internal+    , Data.Sequence.FastQueue+    , Data.Sequence.FastQueue.Internal+    , Data.Sequence.FastCatQueue+    , Data.Sequence.ToCatQueue+    , Data.Sequence.ToCatQueue.Internal+    , Data.Sequence.FastQueue.Internal.Any++test-suite sequence-test+  if impl(ghc < 7.10)+    buildable: False+  ghc-options: -Wall -fno-warn-unused-imports+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  default-language: Haskell2010+  main-is:          Test.hs+  other-modules:    FastQueue+                  , BSeq+                  , Queue+                  , ToCatQueue+                  , Valid+  build-depends:    base >=4.5 && < 5+                  , sequence+                  , tasty >= 1.4+                  , QuickCheck+                  , tasty-quickcheck++test-suite do-nothing+  if impl(ghc >= 7.10)+    buildable: False+  type:             exitcode-stdio-1.0+  hs-source-dirs:   fake-test+  default-language: Haskell2010+  main-is:          Test.hs+  build-depends:    base >=4.5 && < 5  source-repository head     type:     git
+ test/BSeq.hs view
@@ -0,0 +1,32 @@+{-# language BangPatterns #-}+{-# options_ghc -fno-warn-orphans #-}+module BSeq where+import Data.Sequence.BSeq.Internal+import Test.QuickCheck+import Valid+++instance Valid BSeq where+  valid Empty = property True+  valid x = counterexample "Empty under Node" $ valid' x+    where+      valid' Empty = False+      valid' (Leaf _) = True+      valid' (Node l r) = valid' l && valid' r++instance Arbitrary a => Arbitrary (BSeq a) where+  arbitrary = liftArbitrary arbitrary++instance Arbitrary1 BSeq where+  liftArbitrary el = sized $ \s -> do+    len <- chooseInt (0, s)+    mkArb len el++-- Generate an arbitrary sequence of exactly the given size.+mkArb :: Int -> Gen a -> Gen (BSeq a)+mkArb 0 _ = pure Empty+mkArb 1 g = Leaf <$> g+mkArb n g = do+  fs <- chooseInt (1, n - 1)+  let rs = n - fs+  Node <$> mkArb fs g <*> mkArb rs g
+ test/FastQueue.hs view
@@ -0,0 +1,34 @@+{-# language BangPatterns #-}+{-# options_ghc -fno-warn-orphans #-}++module FastQueue where+import Data.Sequence.FastQueue.Internal+import Test.QuickCheck+import Data.Sequence.FastQueue.Internal.Any+import Data.List (replicate)+import Valid++instance Valid FastQueue where+  valid (RQ front rear schedule) =+    counterexample "fails |front| = |rear| + |sched|" $+    length front === slen rear + length schedule++instance Arbitrary a => Arbitrary (FastQueue a) where+  arbitrary = liftArbitrary arbitrary++instance Arbitrary1 FastQueue where+  liftArbitrary el = do+    NonNegative rear_len <- arbitrary+    NonNegative schedule_len <- arbitrary+    rear <- sworp <$> vectorOf rear_len el+    front <- vectorOf (schedule_len + rear_len) el+    pure $ RQ front rear (replicate schedule_len (toAny ()))+    where+      sworp [] = SNil+      sworp (x : xs) = sworp xs :> x++slen :: SL a -> Int+slen = go 0+  where+    go !acc SNil = acc+    go acc (xs :> _) = go (acc + 1) xs
+ test/Queue.hs view
@@ -0,0 +1,61 @@+{-# language BangPatterns #-}+{-# options_ghc -fno-warn-orphans #-}++module Queue where+import Data.Sequence.Queue.Internal+import Test.QuickCheck+import Valid++{-+data P a = a :* a+  deriving (Functor, Foldable, Traversable)++data B a where+  B1 :: a    -> B a+  B2 :: !(P a)  -> B a++data Queue a  where+  Q0 :: Queue a+  Q1 :: a  -> Queue a+  QN :: !(B a) -> Queue (P a) -> !(B a) -> Queue a+  -}+++instance Valid Queue where+  -- Just force the structure to make sure it's finite+  -- and fully defined.+  valid = property . foldr (\_ r -> r) True++instance Arbitrary a => Arbitrary (Queue a) where+  arbitrary = liftArbitrary arbitrary++instance Arbitrary1 Queue where+  liftArbitrary el = sized $ \s -> do+    len <- chooseInt (0, s)+    mkArbQ len el++-- Generate an arbitrary queue of exactly the given size.+mkArbQ :: Int -> Gen a -> Gen (Queue a)+mkArbQ 0 _ = pure Q0+mkArbQ 1 g = Q1 <$> g+mkArbQ 2 g = QN <$> mkArbB 1 g <*> pure Q0 <*> mkArbB 1 g+mkArbQ 3 g = oneof+  [ QN <$> mkArbB 1 g <*> pure Q0 <*> mkArbB 2 g+  , QN <$> mkArbB 2 g <*> pure Q0 <*> mkArbB 1 g ]+mkArbQ n g+  | even n+  = oneof+      [ QN <$> mkArbB 2 g <*> mkArbQ ((n - 4) `quot` 2) (mkArbP g) <*> mkArbB 2 g+      , QN <$> mkArbB 1 g <*> mkArbQ ((n - 2) `quot` 2) (mkArbP g) <*> mkArbB 1 g ]+  | otherwise+  = oneof+      [ QN <$> mkArbB 2 g <*> mkArbQ ((n - 3) `quot` 2) (mkArbP g) <*> mkArbB 1 g+      , QN <$> mkArbB 1 g <*> mkArbQ ((n - 3) `quot` 2) (mkArbP g) <*> mkArbB 2 g ]++mkArbB :: Int -> Gen a -> Gen (B a)+mkArbB 1 g = B1 <$> g+mkArbB 2 g = B2 <$> mkArbP g+mkArbB _ _ = error "mkArbB must be called with 1 or 2."++mkArbP :: Gen a -> Gen (P a)+mkArbP g = (:*) <$> g <*> g
+ test/Test.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}++import Test.Tasty+import Test.Tasty.QuickCheck as QC hiding ((><))+import Data.SequenceClass+import Valid+import Data.Proxy+import Data.Foldable++import FastQueue ()+import Data.Sequence.FastQueue+import BSeq ()+import Data.Sequence.BSeq+import Queue ()+import Data.Sequence.Queue+import ToCatQueue ()+import Data.Sequence.ToCatQueue++type Usable s = (Arbitrary (s Int), Show (s Int), Eq (s Int), Valid s, Sequence s)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+  [ testsFor "FastQueue" (Proxy :: Proxy FastQueue)+  , testsFor "BSeq" (Proxy :: Proxy BSeq)+  , testsFor "Queue" (Proxy :: Proxy Queue)+  , testsFor "ToCatQueue FastQueue" (Proxy :: Proxy (ToCatQueue FastQueue))+  , testsFor "ToCatQueue Queue" (Proxy :: Proxy (ToCatQueue Queue))+  ]++testsFor :: Usable s => String -> Proxy s -> TestTree+testsFor s p = testGroup (s ++ " Tests") [properties p]++properties :: Usable s => Proxy s -> TestTree+properties p = testGroup "Properties" [qcProps p]++qcProps :: Usable s => Proxy s -> TestTree+qcProps (_ :: Proxy s) = testGroup "(checked by QuickCheck)" $+  [ QC.testProperty "generator valid" $+     -- We avoid trying to show an invalid generated sequence+     -- because doing so may raise an exception.+     forAllBlind (arbitrary :: Gen (s Int)) valid+  , QC.testProperty "viewl works" $+      \(s :: s Int) -> case viewl s of+        EmptyL -> null s .&&. s === empty+        a :< as -> valid as .&&. toList s === a : toList as .&&. a <| as === s+  , QC.testProperty "viewr works" $+      \(s :: s Int) -> case viewr s of+        EmptyR -> null s .&&. s === empty+        as :> a -> valid as .&&. toList s === toList as ++ [a] .&&.+                      as |> a === s+  , QC.testProperty ">< works" $+      \(s :: s Int) t -> let st = s >< t in+        valid st .&&. toList st === toList s ++ toList t+  , QC.testProperty ">< is associative" $+      \(s :: s Int) t u -> (s >< t) >< u === s >< (t >< u)+  , QC.testProperty "empty is identity" $+      \(s :: s Int) -> s >< empty === s .&&. empty >< s === s+  , QC.testProperty "foldMap/singleton" $+      \(x :: Int) ->+        let s = singleton x :: s Int+        in valid s .&&. foldMap (:[]) s === [x]+  , QC.testProperty "fromList works" $+      \(l :: [Int]) -> let s = fromList l :: s Int in+        valid s .&&. toList s === l .&&. s === foldl' (|>) empty l+  ]
+ test/ToCatQueue.hs view
@@ -0,0 +1,57 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# options_ghc -fno-warn-orphans #-}++module ToCatQueue where+import Data.SequenceClass+import Data.Sequence.ToCatQueue.Internal+import Test.QuickCheck+import Data.List (replicate)+import Data.Foldable (all)+import Valid++{-+data ToCatQueue q a where+  C0 :: ToCatQueue q a+  CN :: a -> !(q (ToCatQueue q a)) -> ToCatQueue q a+  -}++instance Sequence q => Valid (ToCatQueue q) where+  valid C0 = property True+  valid (CN _ q0) = counterexample "Empty queue in simple queue" $ valid' q0+    where+      valid' = all $ \case+        C0 -> False+        CN _ q -> valid' q++instance (Sequence q, Arbitrary a) => Arbitrary (ToCatQueue q a) where+  arbitrary = liftArbitrary arbitrary++-- We are testing only ToCatQueue here, and assume the underlying+-- queue works correctly. So we don't try to generate arbitrary+-- shapes of the underlying queue; we just build those from lists.+instance Sequence q => Arbitrary1 (ToCatQueue q) where+  liftArbitrary el = sized $ \s -> do+    n <- chooseInt (0, s)+    mkArb el n+    +mkArb :: Sequence q => Gen a -> Int -> Gen (ToCatQueue q a)+mkArb _ 0 = pure C0+mkArb g n = do+  x <- g  -- Pick the first element+  sizes <- splat (n - 1) -- Decide how to arrange the remaining ones+  xs <- fromList <$> traverse (mkArb g) sizes+  pure (CN x xs)++  --  rear <- sworp <$> vectorOf rear_len el++-- Generate a partition of a non-negative integer into+-- positive integers. This is not statistically fair; it+-- might be nice to make it so.+splat :: Int -> Gen [Int]+splat n | n < 0 = error "Can't splat a negative number"+splat 0 = pure []+splat n = do+  k <- chooseInt (1, n)+  rest <- splat (n - k)+  pure (k : rest)
+ test/Valid.hs view
@@ -0,0 +1,7 @@+module Valid (Valid (..)) where++import Test.QuickCheck++class Valid s where+  -- Check the invariants of a sequence.+  valid :: s a -> Property