diff --git a/Data/Collections.hs b/Data/Collections.hs new file mode 100644 --- /dev/null +++ b/Data/Collections.hs @@ -0,0 +1,594 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-name-shadowing -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Collections +-- Copyright : (c) Jean-Philippe Bernardy, 2006 +-- License : BSD3 +-- Maintainer : jeanphilippe.bernardy; google mail. +-- Stability : experimental +-- +-- This module defines a class framework for collection types. It provides: +-- +-- * Classes for the most common type of collections +-- +-- * /View/ types to change the type of a collection, so it implements other classes. +-- This allows to use types for purposes that they are not originally designed for. (eg. 'ElemsView') +-- +-- * A few generic functions for handling collections. +-- +-- * Infix (operator) version of common functions. +-- +-- Should you need a more precise documentation, "Data.Collections.Properties" lists laws that +-- implementations are entitled to assume. +-- +-- The classes defined in this module are intended to give hints about performance. +-- eg. if a function has a @'Map' c k v@ context, this indicates that the function +-- will perform better if @c@ has an efficitent lookup function. +-- +-- This class framework is based on ideas found in Simon Peyton Jones, \"/Bulk types with class/\". +-- +-- +-- Another inspiration source are the examples of MPTC and fuctional dependencies in Oleg Kiselyov's +-- many articles posted to the haskell mailing list. +-- +-- +-- This module name-clashes with a lot of Prelude functions, subsuming those. +-- The user is encouraged to import Prelude hiding the clashing functions. +-- Alternatively, it can be imported @qualified@. +-- + + +{- + + +Selling points: + * Unification of Map and Set (required by the below) + * inclusion of Arrays + * Good integration with existing base libraries + * Relative simplicity: few classes, not too many methods, very little redundancy. + * Reuses the same identifiers as other standard hierarchy modules. + Conversion from the module-based API to this class-based one should be easy. + * Comprehensive set of properties that define the behaviour of the classes. + * Compatibility with GHC and Hugs. + +Bad points + * Extra complexity due to heavy usage of MTPC (although imho it's a matter of getting used to it) + +TODO: + * test with nhc98/hugs + * add missing functions (partition, ..., ?) + * optimizations (rules pragmas) + * see how multimap/multiset fits this scheme. + * Think about class Map' :: (* -> *) -> * -> $ + * Fix infelicity about null map test; (== mempty). +-} + +module Data.Collections + ( +-- * Classes +-- ** Unfoldable + Unfoldable(..), +-- ** Collection + Collection(..), + SortingCollection(..), +-- ** Map + Map(..), + lookupWithDefault, + unionsWith, + intersectionWith', + differenceWith', + mapWithKey', + (!), +-- ** Set + Set(..), + unions, + notMember, + (\\), +-- ** Sequence + Sequence(..), + head, + tail, + append, + concat, + concatMap, +-- length, + (<|), + (|>), + (><), +-- ** Others + Array(..), + Indexed(..), + + +-- * Conversions + fromFoldable, + fromAscFoldable, + fromList, + fromListWith, + fromAscList, + +-- * Views + KeysView(..), ElemsView(..), + withKeys, withElems, +-- * Foldable + module Data.Collections.Foldable, + + + ) where + +-- import Prelude (Bool(..), Int, Maybe(..), +-- (==), (.), (+), ($), (-), (&&), (||), +-- Eq, Ord, +-- error, const, not, fst, snd, maybe, head, otherwise, curry, uncurry, flip, +-- min, max, Show) + +import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldr1,foldl,null,reverse,(++),minimum,maximum,all,elem,concatMap,drop,head,tail,init) + +import Data.Monoid +import Data.Collections.Foldable + +import qualified Data.Array as Array +import qualified Data.List as List +import qualified Data.Maybe as Maybe + +infixl 9 ! +infixl 9 \\ -- + +infixr 5 >< +infixr 5 <| +infixl 5 |> + +------------------------------------------------------------------------ +-- * Type classes + +-- | Class of collection types. + +class (Foldable c a, Unfoldable c a) => Collection c a | c -> a where + -- | @filter f c@ returns the collection of those elements that satisfy the predicate @f@. + filter :: (a -> Bool) -> c -> c + +-- | Class of collection with unobservable elements. It is the dual of the 'Foldable' class. + +class Unfoldable c i | c -> i where + + -- | \'natural\' insertion of an element into a collection. + insert :: i -> c -> c + --insert i c = cofold (\Right c -> Right c; Left (i,c) -> Left (i,Right c)) (Left (i,c)) + -- | The empty collection. + empty :: c + empty = unfold (const Nothing) undefined + + -- | Creates a collection with a single element. + singleton :: i -> c + singleton i = insert i empty + + -- | Insert all the elements of a foldable. + insertMany :: Foldable c' i => c' -> c -> c + insertMany c' c = foldr insert c c' + -- At first sight, it looks like the above could just use List instead of any Foldable. + -- However, it would then be more difficult to ensure that the conversion could be made + -- very efficient between certain types. + + -- | Same as insertMany, but with the unchecked precondition that the input 'Foldable' is sorted. + insertManySorted :: Foldable c' i => c' -> c -> c + insertManySorted = insertMany + +unfold :: Unfoldable c a => (b -> Maybe (a, b)) -> b -> c +unfold f b = insertMany (List.unfoldr f b) empty + +class Collection c o => SortingCollection c o where + minView :: c -> Maybe (o,c) + +-- isSorted :: (Ord a, Foldable c a) => c -> Bool +-- isSorted = fst . foldr cmp (True, Nothing) +-- where curr `cmp` (acc, prev) = (acc && maybe True (curr <=) prev, Just curr) + +-- | Conversion from a Foldable to a Collection. +fromFoldable :: (Foldable f a, Collection c' a) => f -> c' +fromFoldable = flip insertMany empty + +-- TODO: Should be specialized (RULE pragmas) so it's efficient when converting from/to set/maps + + +-- | Conversion from a Foldable to a Collection, with the /unchecked/ precondition that the input is sorted +fromAscFoldable :: (Foldable f a, Collection c' a) => f -> c' +fromAscFoldable = flip insertManySorted empty + +-- | Converts a list into a collection. +fromList :: Collection c a => [a] -> c +fromList = fromFoldable + +-- | Converts a list into a collection, with the precondition that the input is sorted. +fromAscList :: Collection c a => [a] -> c +fromAscList = fromAscFoldable + + +-- | Class of sequential-access types. +-- In addition of the 'Collection' services, it provides deconstruction and concatenation. +class (Monoid c, Collection c a) => Sequence c a where + -- | The first @i@ elements of a sequence. + take :: Int -> c -> c + -- | Elements of a sequence after the first @i@. + drop :: Int -> c -> c + -- | Split a sequence at a given index. + splitAt :: Int -> c -> (c,c) + -- | Reverse a sequence. + reverse :: c -> c + -- | Analyse the left end of a sequence. + front :: c -> Maybe (a,c) + -- | Analyse the right end of a sequence. + back :: c -> Maybe (c,a) + -- | Add an element to the left end of a sequence. + cons :: a -> c -> c + -- | Add an element to the right end of a sequence. + snoc :: c -> a -> c + -- | The 'isPrefix' function takes two seqences and returns True iff + -- the first is a prefix of the second. + isPrefix :: Eq a => c -> c -> Bool + + cons = insert + isPrefix s1 s2 + = case front s1 of + Nothing -> True + Just (x,xs) -> + case front s2 of + Nothing -> False + Just (y,ys) -> x == y && isPrefix xs ys + + +-- -- | Length of a sequence +-- length :: Sequence c i o => c -> Int +-- length = size + +-- | Concatenate two sequences. +append :: Sequence c a => c -> c -> c +append = mappend + +-- TODO: span ? + +-- | Infix version of 'cons': add an element to the left end of a sequence. +-- Mnemonic: a triangle with the single element at the pointy end. +(<|) :: Sequence c i => i -> c -> c +(<|) = cons + +-- | Infix version of 'snoc': add an element to the right end of a sequence. +-- Mnemonic: a triangle with the single element at the pointy end. +(|>) :: Sequence c i => c -> i -> c +(|>) = snoc + +-- | Infix verion of 'append'. Concatenate two sequences. +(><) :: Sequence c a => c -> c -> c +(><) = append + + +-- | The concatenation of all the elements of a container of sequences. +concat :: (Sequence s a, Foldable t s) => t -> s +concat = fold + +-- | Map a function over all the elements of a container and concatenate +-- the resulting sequences. +concatMap :: (Sequence s b, Foldable t a) => (a -> s) -> t -> s +concatMap = foldMap + +head :: Sequence s a => s -> a +head = fst . Maybe.fromJust . front + +tail :: Sequence s a => s -> s +tail = drop 1 + +-- | Class of indexed types. +-- The collection is 'dense': there is no way to /remove/ an element nor for lookup +-- to return "not found". +-- +-- In practice however, most shallow collection types will instanciate this +-- class in addition of 'Map', and leave the responsibility of failure to the caller. +class Indexed c k v | c -> k v where + -- | @index c k@ returns element associated to @k@ + index :: k -> c -> v + -- | @adjust f k c@ applies @f@ to element associated to @k@ and returns the resulting collection. + adjust :: (v -> v) -> k -> c -> c + -- | if @inDomain k c@, then @index c k@ is guaranteed not to fail. + inDomain :: k -> c -> Bool + -- | Constructs a collection identical to the first argument except that it has + -- been updated by the associations in the right argument. + -- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then + -- + -- > m//[((i,i), 0) | i <- [1..n]] + -- + -- is the same matrix, except with the diagonal zeroed. + (//) :: Foldable l (k,v) => c -> l -> c + (//) = foldr replace + where replace (k,v) = adjust (const v) k + -- | @'accum' f@ takes an array and an association list and accumulates + -- pairs from the list into the array with the accumulating function @f@. + -- Thus 'accumArray' can be defined using 'accum': + accum :: Foldable l (k,v') => (v -> v' -> v) -> c -> l -> c + accum f = foldr adjust' + where adjust' (k,v') = adjust (\v->f v v') k + +-- | Infix version of 'index', with arguments swapped. +(!) :: Indexed c k v => c -> k -> v +(!) = flip index + +class (Array.Ix k, Foldable c (k,v), Indexed c k v) => Array c k v | c -> k v where + -- | if @(l,r) = bounds c@, then @inDomain k c <==> l <= k <= r@ + bounds :: c -> (k,k) + -- | Construct an array with the specified bounds and containing values + -- for given indices within these bounds. + -- + -- The array is undefined (i.e. bottom) if any index in the list is + -- out of bounds. The Haskell 98 Report further specifies that if any + -- two associations in the list have the same index, the value at that + -- index is undefined (i.e. bottom). However in GHC's implementation, + -- the value at such an index is the value part of the last association + -- with that index in the list. + -- + -- Because the indices must be checked for these errors, 'array' is + -- strict in the bounds argument and in the indices of the association + -- list, but nonstrict in the values. Thus, recurrences such as the + -- following are possible: + -- + -- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]]) + -- + -- Not every index within the bounds of the array need appear in the + -- association list, but the values associated with indices that do not + -- appear will be undefined (i.e. bottom). + -- + -- If, in any dimension, the lower bound is greater than the upper bound, + -- then the array is legal, but empty. Indexing an empty array always + -- gives an array-bounds error, but 'bounds' still yields the bounds + -- with which the array was constructed. + array :: Foldable l (k,v) => (k,k) -> l -> c + + +-- | Class of map-like types. (aka. for sparse associative types). +-- +-- In opposition of Indexed, Map supports unexisting value for some indices. +class Monoid c => Map c k a | c -> k a where + -- | Remove a key from the keySet (and therefore the associated value in the Map). + delete :: k -> c -> c + delete = alter (const Nothing) + + -- | Tells whether an key is member of the keySet. + member :: k -> c -> Bool + member k = Maybe.isJust . lookup k + + -- | Union of two keySets. + -- When duplicates are encountered, the keys may come from any of the two input sets. + -- Values come from the map given as first arguement. + union :: c -> c -> c + union = unionWith const + + -- | Intersection of two keySets. + -- + -- When duplicates are encountered, the keys may come from any of the two input sets. + -- Values come from the map given as first arguement. + intersection :: c -> c -> c + intersection = intersectionWith const + + -- | Difference of two keySets. + -- Difference is to be read infix: @a `difference` b@ returns a set containing the + -- elements of @a@ that are also absent from @b@. + difference :: c -> c -> c + difference = differenceWith (\_ _-> Nothing) + + + -- | @s1 `isSubset` s2@ returns True iff. the keys in s1 form a subset of the keys in s2. + isSubset :: c -> c -> Bool + isSubset = isSubmapBy (\_ _->True) + + -- | @s1 `isProperSubset` s2@ returns True iff. @s1 `isProperSubset` s2@ and @s1 /= s2@ + isProperSubset :: c -> c -> Bool + isProperSubset = isProperSubmapBy (\_ _->True) + +-- Follows functions for fully-fledged maps. + -- | Lookup the value at a given key. + lookup :: k -> c -> Maybe a + + -- | Change the value associated to a given key. 'Nothing' represents no associated value. + alter :: (Maybe a -> Maybe a) -> k -> c -> c + alter f k m = case lookup k m of + j@(Just _) -> case f j of + Just a' -> insertWith (\a _ -> a) k a' m + Nothing -> delete k m + Nothing -> case f Nothing of + Just a' -> insertWith (\a _ -> a) k a' m + Nothing -> m + + -- | Insert with a combining function. + -- + -- @insertWith f key value m@ + -- will insert the pair @(key, value)@ into @m@ if @key@ does + -- not exist in the map. If the key does exist, the function will + -- insert the pair @(key, f new_value old_value)@. + insertWith :: (a -> a -> a) -> k -> a -> c -> c + insertWith f k a c = alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k c + + -- | Convert a 'Foldable' to a 'Map', with a combining function. + -- Note the applications of the combining function: + -- @fromFoldableWith (+) [(k,x1), (k,x2), ..., (k,xn)] = fromFoldable [(k, xn + (... + (x2 + x1)))]@ + -- or more generally @fromFoldableWith f [(k,x) | x <- l] = fromFoldable [(k,foldl1 (flip f) l)]@ + -- 'foldGroups' is probably less surprising, so use it. + fromFoldableWith :: Foldable l (k,a) => (a -> a -> a) -> l -> c + fromFoldableWith f = foldr (uncurry (insertWith f)) mempty + + -- | Convert a 'Foldable' to a 'Map', with a combining function. + -- @foldGroups f a l = let mkGroup g = (fst $ head g, foldr f a (map snd g)) in fromList . map mkGroup . groupBy ((==) `on` fst)) . toList@ + foldGroups :: Foldable l (k,b) => (b -> a -> a) -> a -> l -> c + foldGroups f a = foldr' (\(k,b) c -> (alter (\x -> Just $ case x of {Nothing->f b a;Just a' -> f b a'}) k c)) mempty + + -- | Apply a function over all values in the map. + mapWithKey :: (k -> a -> a) -> c -> c + + -- | Union with a combining function. + unionWith :: (a -> a -> a) -> c -> c -> c + + -- | Intersection with a combining function. + intersectionWith :: (a -> a -> a) -> c -> c -> c + + -- | Difference with a combining function. + differenceWith :: (a -> a -> Maybe a) -> c -> c -> c + + -- | isSubmapBy + isSubmapBy :: (a -> a -> Bool) -> c -> c -> Bool + + -- | isProperSubmapBy + isProperSubmapBy :: (a -> a -> Bool) -> c -> c -> Bool + -- isProperSubmapBy f m1 m2 = isSubmapBy f m1 m2 && not (isEmpty (differenceWith (\_ _->Nothing) m1 m2)) + +-- | Tells whether a key is not a member of the keySet. +notMember :: (Map c k a) => k -> c -> Bool +notMember k s = not $ member k s + +-- | The expression @('lookupWithDefault' def k map)@ returns +-- the value at key @k@ or returns @def@ when the key is not in the map. +lookupWithDefault :: (Map c k a) => a -> k -> c -> a +lookupWithDefault a k c = Maybe.fromMaybe a (lookup k c) + +-- | Specialized version of fromFoldableWith for lists. +fromListWith :: (Map c k a) => (a -> a -> a) -> [(k,a)] -> c +fromListWith = fromFoldableWith + +data O a b c = L !a | R !b | O !c + +-- | Same as 'intersectionWith', but with a more general type. +intersectionWith' :: (Functor m, Map (m (O a b c)) k (O a b c)) => + (a->b->c) -> m a -> m b -> m c +intersectionWith' f m1 m2 = fmap extract (intersectionWith combine (fmap L m1) (fmap R m2)) + where combine (L l) (R r) = O (f l r) + extract (O a) = a + +-- | Same as 'differenceWith', but with a more general type. +differenceWith' :: (Functor m, Map (m (O a b c)) k (O a b c)) => + (a->b->Maybe c) -> m a -> m b -> m c +differenceWith' f m1 m2 = fmap extract (differenceWith combine (fmap L m1) (fmap R m2)) + where combine (L l) (R r) = fmap O (f l r) + extract (O a) = a + +mapWithKey' :: (Functor m, Map (m (Either a b)) k (Either a b)) => + (k -> a -> b) -> m a -> m b +mapWithKey' f = fmap (either (error "mapWithKey': bug.") id) . mapWithKey f' . fmap Left + where f' k (Left x) = Right (f k x) + +-- | Class for set-like collection types. A set is really a map +-- with no value associated to the keys, +-- so Set just states so. + +-- Note that this should be a class alias, if it existed. +-- See: http://repetae.net/john/recent/out/classalias.html +class Map c k () => Set c k | c -> k where + -- | Dummy method for haddock to accept the class. + haddock_candy :: c -> k + +-- | Infix version of 'difference'. Difference of two (key) sets. +(\\) :: Map c k a => c -> c -> c +(\\) = difference + +-- NOTE: the following two are only tentative, and thus not exported. + +-- | Infix version of 'union'. Union of two (key) sets. +(\/) :: Map c k a => c -> c -> c +(\/) = union + +-- | Infix version of 'intersection'. Intersection of two (key) sets. +(/\) :: Map c k a => c -> c -> c +(/\) = intersection + + +{- + +Maybe it would be a good idea to bite the bullet and use a Lattice class for intersection and union. +Maybe leave it unrelated to the Map class. In a separate module/package? Something like: + + +class Lattice a where + (/\) :: a -> a -> a + (\/) :: a -> a -> a + +instance Lattice () where + _ /\ _ = () + _ \/ _ = () + +instance Lattice Bool where + (/\) = (&&) + (\/) = (||) + +instance (Lattice a, Map c k a) => Lattice c where + (/\) = intersectionWith (/\) + (\/) = unionWith (\/) + +-} + + + +-- | Union of many (key) sets. +unions :: (Unfoldable s i, Map s k a, Foldable cs s) => cs -> s +unions sets = foldl' union empty sets + +-- | Union of many (key) sets, with combining function +unionsWith :: (Unfoldable s i, Map s k a, Foldable cs s) => (a->a->a) -> cs -> s +unionsWith f sets = foldl' (unionWith f) empty sets + +------------------------------------------------------------------------ +-- Trickier stuff for alternate dictionnary usages + +-- | "View" to the keys of a dictionnary +newtype KeysView m k v = KeysView {fromKeysView :: m} + +-- | "View" to the elements of a dictionnary +newtype ElemsView m k v = ElemsView {fromElemsView :: m} + +-- The following requires undecidable instances. An alternative +-- implementation is to define these instances directly on the +-- concrete map types and drop the requirement for the aforementioned +-- extension. + +type T a = a->a + +withKeys :: Collection m (k,v) => T (KeysView m k v) -> T m +withKeys f c = fromKeysView $ f (KeysView c) + +withElems :: Collection m (k,v) => T (ElemsView m k v) -> T m +withElems f c = fromElemsView $ f (ElemsView c) + +instance Foldable m (k,v) => Foldable (KeysView m k v) k where + foldr f i (KeysView c) = foldr (f . fst) i c + null (KeysView c) = null c + +instance Unfoldable m (k,v) => Unfoldable (KeysView m k v) (k,v) where + empty = KeysView empty + insert x (KeysView m) = KeysView $ insert x m + singleton x = KeysView (singleton x) + +instance Foldable m (k,v) => Foldable (ElemsView m k v) v where + foldr f i (ElemsView c) = foldr (f . snd) i c + null (ElemsView c) = null c + +instance Unfoldable m (k,v) => Unfoldable (ElemsView m k v) (k,v) where + empty = ElemsView empty + insert x (ElemsView m) = ElemsView $ insert x m + singleton x = ElemsView (singleton x) + +instance (Monoid m, Map m k v) => Monoid (KeysView m k v) where + mempty = KeysView mempty + mappend = union + +instance Map m k v => Map (KeysView m k v) k v where + isSubmapBy f (KeysView m) (KeysView m') = isSubmapBy f m m' + isProperSubmapBy f (KeysView m) (KeysView m') = isProperSubmapBy f m m' + member k (KeysView m) = Maybe.isJust $ lookup k m + union (KeysView m) (KeysView m') = KeysView $ union m m' + difference (KeysView m) (KeysView m') = KeysView $ difference m m' + intersection (KeysView m) (KeysView m') = KeysView $ intersection m m' + delete k (KeysView m) = KeysView $ delete k m + insertWith f k a (KeysView m) = KeysView $ insertWith f k a m + lookup k (KeysView m) = lookup k m + alter f k (KeysView m) = KeysView $ alter f k m + unionWith f (KeysView m) (KeysView m') = KeysView $ unionWith f m m' + differenceWith f (KeysView m) (KeysView m') = KeysView $ differenceWith f m m' + intersectionWith f (KeysView m) (KeysView m') = KeysView $ intersectionWith f m m' + mapWithKey f (KeysView m) = KeysView $ mapWithKey f m + + + diff --git a/Data/Collections/Foldable.hs b/Data/Collections/Foldable.hs new file mode 100644 --- /dev/null +++ b/Data/Collections/Foldable.hs @@ -0,0 +1,313 @@ +{-# OPTIONS -fglasgow-exts -cpp -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Collections.Foldable +-- Copyright : Ross Paterson 2005, adaptation to MPTC+FD by Jean-Philippe Bernardy +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : jeanphilippe.bernardy (google mail address) +-- Stability : experimental +-- Portability : MPTC+FD +-- +-- Class of data structures that can be folded to a summary value. + +module Data.Collections.Foldable ( + -- * Folds + Foldable(..), + -- ** Special biased folds + foldr', + foldl', + foldrM, + foldlM, + -- ** Folding actions + -- *** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- *** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- ** Specialized folds + toList, + --More general versions exist in Data.Collections + --concat, + --concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + maximumBy, + minimum, + minimumBy, + -- ** Searches + elem, + notElem, + find + ) where + +import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, + elem, notElem, concat, concatMap, and, or, any, all, + sum, product, maximum, minimum) +import qualified Prelude (foldl, foldr, foldl1, foldr1) +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid +import Data.Array + +#ifdef __NHC__ +import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (build) +#endif + +-- | Data structures that can be folded. +-- +-- Minimal complete definition: 'foldMap' or 'foldr'. +-- +-- For example, given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Foldable Tree +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r +-- +-- This is suitable even for abstract types, as the monoid is assumed +-- to satisfy the monoid laws. +-- +class Foldable t a | t -> a where + -- | Combine the elements of a structure using a monoid. + fold :: Monoid a => t -> a + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t -> m + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + foldr :: (a -> b -> b) -> b -> t -> b + foldr f z t = appEndo (foldMap (Endo . f) t) z + + -- | Left-associative fold of a structure. + -- + -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + foldl :: (b -> a -> b) -> b -> t -> b + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t -> a + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where mf x Nothing = Just x + mf x (Just y) = Just (f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t -> a + foldl1 f xs = fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) + where mf Nothing y = Just y + mf (Just x) y = Just (f x y) + + -- | Tells whether the structure is empty. + null :: t -> Bool + null = all (const False) + + -- | Returns the size of the structure. + size :: t -> Int + size = foldr (const (+1)) 0 + + -- | Tells whether the structure contains a single element. + isSingleton :: t -> Bool + isSingleton = (1 ==) . size -- FIXME: more efficient default. + +-- instances for Prelude types + +instance Foldable (Maybe a) a where + foldr _ z Nothing = z + foldr f z (Just x) = f x z + + foldl _ z Nothing = z + foldl f z (Just x) = f z x + +instance Foldable [a] a where + null = Prelude.null + size = Prelude.length + foldr = Prelude.foldr + foldl = Prelude.foldl + foldr1 = Prelude.foldr1 + foldl1 = Prelude.foldl1 + +instance Ix i => Foldable (Array i a) (i,a) where + foldr f z = Prelude.foldr f z . assocs + +-- | Fold over the elements of a structure, +-- associating to the right, but strictly. +foldr' :: Foldable t a => (a -> b -> b) -> b -> t -> b +foldr' f z xs = foldl f' id xs z + where f' k x z = k $! f x z + +-- | Monadic fold over the elements of a structure, +-- associating to the right, i.e. from right to left. +foldrM :: (Foldable t a, Monad m) => (a -> b -> m b) -> b -> t -> m b +foldrM f z xs = foldl f' return xs z + where f' k x z = f x z >>= k + +-- | Fold over the elements of a structure, +-- associating to the left, but strictly. +foldl' :: Foldable t b => (a -> b -> a) -> a -> t -> a +foldl' f z xs = foldr f' id xs z + where f' x k z = k $! f z x + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldlM :: (Foldable t b, Monad m) => (a -> b -> m a) -> a -> t -> m a +foldlM f z xs = foldr f' return xs z + where f' x k z = f z x >>= k + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverse_ :: (Foldable t a, Applicative f) => (a -> f b) -> t -> f () +traverse_ f = foldr ((*>) . f) (pure ()) + +-- | 'for_' is 'traverse_' with its arguments flipped. +for_ :: (Foldable t a, Applicative f) => t -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to a monadic action, evaluate +-- these actions from left to right, and ignore the results. +mapM_ :: (Foldable t a, Monad m) => (a -> m b) -> t -> m () +mapM_ f = foldr ((>>) . f) (return ()) + +-- | 'forM_' is 'mapM_' with its arguments flipped. +forM_ :: (Foldable t a, Monad m) => t -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | Evaluate each action in the structure from left to right, +-- and ignore the results. +sequenceA_ :: forall f a t. (Foldable t (f a), Applicative f) => t -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | Evaluate each monadic action in the structure from left to right, +-- and ignore the results. +sequence_ :: forall m a t. (Foldable t (m a), Monad m) => t -> m () +sequence_ = foldr (>>) (return ()) + +-- | The sum of a collection of actions, generalizing 'concat'. +asum :: (Foldable t (f a), Alternative f) => t -> f a +{-# INLINE asum #-} +asum = foldr (<|>) empty + +-- | The sum of a collection of actions, generalizing 'concat'. +msum :: (Foldable t (m a), MonadPlus m) => t -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +-- These use foldr rather than foldMap to avoid repeated concatenation. + +-- | List of elements of a structure. +toList :: Foldable t a => t -> [a] +#ifdef __GLASGOW_HASKELL__ +toList t = build (\ c n -> foldr c n t) +#else +toList = foldr (:) [] +#endif + +{- Not used or exported +-- | The concatenation of all the elements of a container of lists. +concat :: Foldable t [a] => t -> [a] +concat = fold +-} + +-- | Map a function over all the elements of a container and concatenate +-- the resulting lists. +concatMap :: Foldable t a => (a -> [b]) -> t -> [b] +concatMap = foldMap + +-- | 'and' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +and :: Foldable t Bool => t -> Bool +and = getAll . foldMap All + +-- | 'or' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +or :: Foldable t Bool => t -> Bool +or = getAny . foldMap Any + +-- | Determines whether any element of the structure satisfies the predicate. +any :: Foldable t a => (a -> Bool) -> t -> Bool +any p = getAny . foldMap (Any . p) + +-- | Determines whether all elements of the structure satisfy the predicate. +all :: Foldable t a => (a -> Bool) -> t -> Bool +all p = getAll . foldMap (All . p) + +-- | The 'sum' function computes the sum of the numbers of a structure. +sum :: (Foldable t a, Num a) => t -> a +sum = getSum . foldMap Sum + +-- | The 'product' function computes the product of the numbers of a structure. +product :: (Foldable t a, Num a) => t -> a +product = getProduct . foldMap Product + +-- | The largest element of the structure. +maximum :: (Foldable t a, Ord a) => t -> a +maximum = foldr1 max + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +maximumBy :: Foldable t a => (a -> a -> Ordering) -> t -> a +maximumBy cmp = foldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-null structure. +minimum :: (Foldable t a, Ord a) => t -> a +minimum = foldr1 min + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +minimumBy :: Foldable t a => (a -> a -> Ordering) -> t -> a +minimumBy cmp = foldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | Does the element occur in the structure? +elem :: (Foldable t a, Eq a) => a -> t -> Bool +elem = any . (==) + +-- | 'notElem' is the negation of 'elem'. +notElem :: (Foldable t a, Eq a) => a -> t -> Bool +notElem x = not . elem x + +-- | The 'find' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +find :: Foldable t a => (a -> Bool) -> t -> Maybe a +find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) diff --git a/Data/Collections/Properties.hs b/Data/Collections/Properties.hs new file mode 100644 --- /dev/null +++ b/Data/Collections/Properties.hs @@ -0,0 +1,682 @@ +{-# OPTIONS_GHC -fglasgow-exts -fno-warn-name-shadowing -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Collections +-- Copyright : (c) Jean-Philippe Bernardy, 2006 +-- License : BSD3 +-- Maintainer : jeanphilippe.bernardy; google mail. +-- Stability : experimental +-- Portability : MPTC, FD, undecidable instances +-- +-- The purpose of this module is twofold: +-- +-- (1) Check instances of the classes in the collection framework. +-- +-- (2) Give those classes more formal semantics. +-- +-- Therefore, this acts as a contract between the collections users and implementers. +-- +-- Each function in this module returns a list of @(property_name, propterty)@ +-- for a given class (or set of classes). Each function is parameterized on the +-- type of +-- the collection to check, so a value witnessing the type must be passed. This +-- value is guaranteed not to be evaluated, so it can always be 'undefined'. +-- +-- These properties allow to verify, with a high degree of confidence, that +-- instances of the classes defined in 'Data.Collections' satisfy +-- the prescribed properties. +-- +-- You will note that properties depend on the 'Eq' class. This means that +-- +-- * properties are verified up to 'Eq' equivalence. +-- +-- * Infinite structures and other @bottom@s are not testable with this module. +-- + + +module Data.Collections.Properties + ( + unfoldable_properties, + foldable_properties, + collection_properties, + map_properties, + map_unfold_properties, + set_unfold_properties, + map_fold_properties, + set_fold_properties, + indexed_map_properties, + sequence_properties, + indexed_properties, + indexed_sequence_properties + ) where + +-- +-- The documentation in this module is mostly generated from the function definitions, +-- see tools/AnnotateProps.hs. +-- TODO: +-- +-- + interactions with other classes (mainly Functor) +-- + see if prop_foldable could be defined better. +-- + array + + +import Prelude hiding (null, foldr, lookup, concatMap, concat, and, drop, take, reverse, elem, notElem, all, any, filter) + +import Control.Monad + +import Data.Collections + +import Data.Collections.Foldable as Foldable + +import Data.Maybe + +import Data.Monoid + +import qualified Data.List as List + +import Test.QuickCheck hiding ((><)) + +import qualified Data.Collections as C + +infix 1 <==> + +infix 1 <== + +instance Show (a->b) where + show _ = "" + +-- | Logic equivalence + +(<==>) :: Bool -> Bool -> Bool +(<==>) x y = x == y + +(<==) = flip (==>) + +-- | foldable_properties returns the following properties: +-- +-- [/size/] +-- +-- > size c == foldr (const (+1)) 0 c +-- +-- [/null/] +-- +-- > null c <==> all (const False) c +-- +-- [/isSingleton/] +-- +-- > isSingleton c <==> size c == 1 +-- +-- [/eq_elem/] +-- +-- > c1 == c2 ==> elem x c1 == elem x c2 -- note that the order of folding is not enforced, and that the converse is not true + +foldable_properties :: forall c a. (Arbitrary c, Arbitrary a, + Show a, Show c, + Eq c, Eq a, + Foldable c a) => c -> [(Property,String)] +foldable_properties _ = [(property prop_size,"size"), (property prop_null,"null"), (property prop_isSingleton,"isSingleton"), (property prop_eq_elem,"eq_elem")] + where size = C.size :: c -> Int + null = C.null :: c -> Bool + foldr = C.foldr :: (a -> b -> b) -> b -> c -> b + toList = C.toList :: c -> [a] + elem = C.elem :: a -> c -> Bool + prop_size c = size c == foldr (const (+1)) 0 c + prop_null c = null c <==> all (const False) c + prop_isSingleton c = isSingleton c <==> size c == 1 + prop_eq_elem c1 c2 x = c1 == c2 ==> elem x c1 == elem x c2 -- note that the order of folding is not enforced, and that the converse is not true + +-- | unfoldable_properties returns the following properties: +-- +-- [/singleton/] +-- +-- > singleton a == insert a empty +-- +-- [/insertMany/] +-- +-- > insertMany l c == Foldable.foldr insert c l +-- +-- [/insertManySorted/] +-- +-- > insertManySorted l c == Foldable.foldr insert c l +-- > where l = List.sort l0 + +unfoldable_properties :: forall c a. (Arbitrary c, Arbitrary a, + Ord a, Show a, Show c, + Eq c, Eq a, + Unfoldable c a) => c -> [(Property,String)] +unfoldable_properties _ = [(property prop_singleton,"singleton"), (property prop_insertMany,"insertMany"), (property prop_insertManySorted,"insertManySorted")] + where empty = C.empty :: c + insert = C.insert :: a -> c -> c + singleton = C.singleton :: a -> c + prop_singleton a = singleton a == insert a empty + prop_insertMany c (l::[a]) = insertMany l c == Foldable.foldr insert c l + prop_insertManySorted c (l0::[a]) = insertManySorted l c == Foldable.foldr insert c l + where l = List.sort l0 + +-- | collection_properties returns the following properties: +-- +-- [/collection/] +-- +-- > foldr insert empty c == c +-- +-- [/empty/] +-- +-- > null empty +-- +-- [/insert1/] +-- +-- > a `elem` (insert a c) -- insert puts the element in the collection +-- +-- [/insert2/] +-- +-- > a /= a' ==> (a' `elem` c <== a' `elem` (insert a c)) -- insert does not insert other elements +-- +-- [/insert3/] +-- +-- > let c' = insert a c in x `elem` c && y `elem` c ==> x `elem` c' || y `elem` c' -- insert alters at most one element +-- +-- [/filter/] +-- +-- > (a `elem` filter f c) <==> ((a `elem` c) && f a) + +collection_properties :: forall c i. (CoArbitrary i, Arbitrary c, Arbitrary i, + Show i, Show c, + Eq c, Eq i, + Collection c i) => c -> [(Property,String)] +collection_properties _ = [(property prop_collection,"collection"), (property prop_empty,"empty"), (property prop_insert1,"insert1"), (property prop_insert2,"insert2"), (property prop_insert3,"insert3"), (property prop_filter,"filter")] + where empty = C.empty :: c + foldr = C.foldr :: (i -> b -> b) -> b -> c -> b + filter = C.filter :: (i -> Bool) -> c -> c + insert = C.insert :: i -> c -> c + + prop_collection c = foldr insert empty c == c + prop_empty = null empty + + prop_insert1 a c = a `elem` (insert a c) -- insert puts the element in the collection + prop_insert2 a a' c = a /= a' ==> (a' `elem` c <== a' `elem` (insert a c)) -- insert does not insert other elements + prop_insert3 a x y c = let c' = insert a c in x `elem` c && y `elem` c ==> x `elem` c' || y `elem` c' -- insert alters at most one element + --NOTE: This leaves the door open to insert actually 'removing' an element. + + prop_filter f c a = (a `elem` filter f c) <==> ((a `elem` c) && f a) + +-- | map_properties returns the following properties: +-- +-- [/alter/] +-- +-- > lookup k (alter f k m) == f (lookup k m) +-- +-- [/mapWithKey/] +-- +-- > lookup k (mapWithKey f m) == fmap (f k) (lookup k m) +-- +-- [/unionWith/] +-- +-- > lookup k (unionWith f m1 m2) == case (lookup k m1, lookup k m2) of +-- > (Nothing,Nothing) -> Nothing +-- > (Just x, Nothing) -> Just x +-- > (Nothing,Just x) -> Just x +-- > (Just x, Just y) -> Just (f x y) +-- +-- [/intersectionWith/] +-- +-- > lookup k (intersectionWith f m1 m2) == case (lookup k m1, lookup k m2) of +-- > (Just x, Just y) -> Just (f x y) +-- > _ -> Nothing +-- +-- [/differenceWith/] +-- +-- > lookup k (differenceWith f m1 m2) == case (lookup k m1, lookup k m2) of +-- > (Just x, Nothing) -> Just x +-- > (Just x, Just y) -> f x y +-- > (Nothing, _) -> Nothing +-- +-- [/isSubmapBy/] +-- +-- > isSubmapBy f m1 m2 <==> differenceWith (\x y->if f x y then Nothing else Just v) m1 m2 == mempty +-- +-- [/isProperSubmapBy/] +-- +-- > isProperSubmapBy f m1 m2 <==> isSubmapBy f m1 m2 && m1 /= m2 +-- +-- [/insertWith/] +-- +-- > insertWith f k a m == alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k m +-- +-- [/fromFoldableWith/] +-- +-- > fromFoldableWith f l == foldr (uncurry (insertWith f)) mempty l +-- +-- [/delete/] +-- +-- > delete k m == alter (const Nothing) k m +-- +-- [/member/] +-- +-- > member k m <==> isJust (lookup k m) +-- +-- [/union/] +-- +-- > union m1 m2 == unionWith const m1 m2 +-- +-- [/intersection/] +-- +-- > intersection m1 m2 == intersectionWith const m1 m2 +-- +-- [/difference/] +-- +-- > difference m1 m2 == differenceWith (\_ _ -> Nothing) m1 m2 +-- +-- [/subset/] +-- +-- > isSubset m1 m2 <==> isSubmapBy (\_ _ -> True) m1 m2 +-- +-- [/properSubset/] +-- +-- > isProperSubset m1 m2 <==> isProperSubmapBy (\_ _ -> True) m1 m2 +-- +-- [/mempty/] +-- +-- > lookup k mempty == Nothing +-- +-- [/mappend/] +-- +-- > mappend m1 m2 == union m1 m2 +-- +-- [/eq_lookup/] +-- +-- > c1 == c2 ==> lookup x c1 == lookup x c2 -- should really be: c1 == c2 <==> forall x. lookup x c1 == lookup x c2 + +map_properties :: forall m k v. (CoArbitrary v, CoArbitrary k, Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, + Map m k v + ) => m -> [(Property,String)] +map_properties _ = [(property prop_alter,"alter"), (property prop_mapWithKey,"mapWithKey"), (property prop_unionWith,"unionWith"), (property prop_intersectionWith,"intersectionWith"), (property prop_differenceWith,"differenceWith"), (property prop_isSubmapBy,"isSubmapBy"), (property prop_isProperSubmapBy,"isProperSubmapBy"), (property prop_insertWith,"insertWith"), (property prop_fromFoldableWith,"fromFoldableWith"), (property prop_delete,"delete"), (property prop_member,"member"), (property prop_union,"union"), (property prop_intersection,"intersection"), (property prop_difference,"difference"), (property prop_subset,"subset"), (property prop_properSubset,"properSubset"), (property prop_mempty,"mempty"), (property prop_mappend,"mappend"), (property prop_eq_lookup,"eq_lookup")] + where +-- empty = C.empty :: m +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe v -> Maybe v) -> k -> m -> m + lookup = C.lookup :: k -> m -> Maybe v + isSubset = C.isSubset :: m -> m -> Bool + isProperSubset = C.isProperSubset :: m -> m -> Bool + isSubmapBy = C.isSubmapBy :: (v -> v -> Bool) -> m -> m -> Bool + unionWith = C.unionWith :: (v -> v -> v) -> m -> m -> m + union = C.union :: m -> m -> m + intersectionWith = C.intersectionWith :: (v -> v -> v) -> m -> m -> m + differenceWith = C.differenceWith :: (v -> v -> Maybe v) -> m -> m -> m + fromFoldableWith = C.fromFoldableWith :: (v -> v -> v) -> [(k,v)] -> m + + prop_alter f k m = lookup k (alter f k m) == f (lookup k m) + + prop_mapWithKey f k m = lookup k (mapWithKey f m) == fmap (f k) (lookup k m) + + prop_unionWith f k m1 m2 = lookup k (unionWith f m1 m2) == case (lookup k m1, lookup k m2) of + (Nothing,Nothing) -> Nothing + (Just x, Nothing) -> Just x + (Nothing,Just x) -> Just x + (Just x, Just y) -> Just (f x y) + + prop_intersectionWith f k m1 m2 = lookup k (intersectionWith f m1 m2) == case (lookup k m1, lookup k m2) of + (Just x, Just y) -> Just (f x y) + _ -> Nothing + + prop_differenceWith f k m1 m2 = lookup k (differenceWith f m1 m2) == case (lookup k m1, lookup k m2) of + (Just x, Nothing) -> Just x + (Just x, Just y) -> f x y + (Nothing, _) -> Nothing + + prop_isSubmapBy f m1 m2 v = isSubmapBy f m1 m2 <==> differenceWith (\x y->if f x y then Nothing else Just v) m1 m2 == mempty + prop_isProperSubmapBy f m1 m2 = isProperSubmapBy f m1 m2 <==> isSubmapBy f m1 m2 && m1 /= m2 + + prop_insertWith f k a m = insertWith f k a m == alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k m + prop_fromFoldableWith f l = fromFoldableWith f l == foldr (uncurry (insertWith f)) mempty l + prop_delete k m = delete k m == alter (const Nothing) k m + prop_member k m = member k m <==> isJust (lookup k m) + prop_union m1 m2 = union m1 m2 == unionWith const m1 m2 + prop_intersection m1 m2 = intersection m1 m2 == intersectionWith const m1 m2 + prop_difference m1 m2 = difference m1 m2 == differenceWith (\_ _ -> Nothing) m1 m2 + prop_subset m1 m2 = isSubset m1 m2 <==> isSubmapBy (\_ _ -> True) m1 m2 + prop_properSubset m1 m2 = isProperSubset m1 m2 <==> isProperSubmapBy (\_ _ -> True) m1 m2 + + prop_mempty k = lookup k mempty == Nothing + prop_mappend m1 m2 = mappend m1 m2 == union m1 m2 + prop_eq_lookup x c1 c2 = c1 == c2 ==> lookup x c1 == lookup x c2 -- should really be: c1 == c2 <==> forall x. lookup x c1 == lookup x c2 + + --prop_eq' c1 c2 = c1 == c2 <==> forAll (\x -> lookup x c1 == lookup x c2) + +count :: Foldable f a => (a -> Bool) -> f -> Int +count p = getSum . foldMap (\x->Sum $ if p x then 1 else 0) + +-- | map_unfold_properties returns the following properties: +-- +-- [/mempty/] +-- +-- > mempty == empty +-- +-- [/insert/] +-- +-- > insert (k,v) m == insertWith (\x _ -> x) k v m + +map_unfold_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, Eq k, + Map m k v, + Collection m (k,v) + ) => m -> [(Property,String)] +map_unfold_properties _ = [(property prop_mempty,"mempty"), (property prop_insert,"insert")] + where + empty = C.empty :: m +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe v -> Maybe v) -> k -> m -> m + lookup = C.lookup :: k -> m -> Maybe v + insertWith = C.insertWith :: (v -> v -> v) -> k -> v -> m -> m + toList = C.toList :: m -> [(k,v)] + + prop_mempty = mempty == empty + prop_insert k v m = insert (k,v) m == insertWith (\x _ -> x) k v m + +-- | map_fold_properties returns the following properties: +-- +-- [/foldable/] +-- +-- > maybeToList (lookup k m) == map snd (List.filter ((== k) . fst) (toList m)) +-- +-- [/size/] +-- +-- > sizeExcept (alter f k m) == sizeExcept m +-- > where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +map_fold_properties :: forall m k v. (CoArbitrary v, Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, Eq k, + Map m k v, + Collection m (k,v) + ) => m -> [(Property,String)] +map_fold_properties _ = [(property prop_foldable,"foldable"), (property prop_size,"size")] + where + empty = C.empty :: m +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe v -> Maybe v) -> k -> m -> m + lookup = C.lookup :: k -> m -> Maybe v + insertWith = C.insertWith :: (v -> v -> v) -> k -> v -> m -> m + toList = C.toList :: m -> [(k,v)] + + prop_foldable k m = maybeToList (lookup k m) == map snd (List.filter ((== k) . fst) (toList m)) + prop_size f k m = sizeExcept (alter f k m) == sizeExcept m + where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +-- | set_unfold_properties returns the following properties: +-- +-- [/mempty/] +-- +-- > mempty == empty +-- +-- [/insert/] +-- +-- > insert k m == insertWith (\x _->x) k () m + +set_unfold_properties :: forall m k. (Arbitrary m, Arbitrary k, + Show k, Show m, + Eq m, Eq k, + Map m k (), + Unfoldable m k + ) => m -> [(Property,String)] +set_unfold_properties _ = [(property prop_mempty,"mempty"), (property prop_insert,"insert")] + where + empty = C.empty :: m + insertWith = C.insertWith :: (() -> () -> ()) -> k -> () -> m -> m + + prop_mempty = mempty == empty + prop_insert k m = insert k m == insertWith (\x _->x) k () m + +-- | set_fold_properties returns the following properties: +-- +-- [/foldable/] +-- +-- > maybeToList (lookup k m) == map (const ()) (List.filter (== k) (toList m)) +-- +-- [/size/] +-- +-- > sizeExcept (alter f k m) == sizeExcept m +-- > where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +set_fold_properties :: forall m k. (Arbitrary m, Arbitrary k, + Show k, Show m, + Eq m, Eq k, + Map m k (), + Foldable m k + ) => m -> [(Property,String)] +set_fold_properties _ = [(property prop_foldable,"foldable"), (property prop_size,"size")] + where +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe () -> Maybe ()) -> k -> m -> m + member = C.member :: k -> m -> Bool + lookup = C.lookup :: k -> m -> Maybe () + + prop_foldable k m = maybeToList (lookup k m) == map (const ()) (List.filter (== k) (toList m)) + prop_size f k m = sizeExcept (alter f k m) == sizeExcept m + where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +-- | indexed_properties returns the following properties: +-- +-- [/adjust/] +-- +-- > k `inDomain` m ==> index k (adjust f k m) == f (index k m) + +indexed_properties :: forall m k v. (CoArbitrary v, Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, + Indexed m k v + ) => m -> [(Property,String)] +indexed_properties _ = [(property prop_adjust,"adjust")] + where adjust = C.adjust :: (v -> v) -> k -> m -> m + + prop_adjust f k m = k `inDomain` m ==> index k (adjust f k m) == f (index k m) + +-- | sequence_properties returns the following properties: +-- +-- [/fold0/] +-- +-- > foldMap f empty == mempty +-- +-- [/fold1/] +-- +-- > foldMap f (x <| s) == f x `mappend` foldMap f s +-- +-- [/fold2/] +-- +-- > foldMap f (s |> x) == foldMap f s `mappend` f x +-- +-- [/fold3/] +-- +-- > foldMap f (s >< t) == foldMap f s `mappend` foldMap f t +-- +-- [/front0/] +-- +-- > front empty == Nothing +-- +-- [/front1/] +-- +-- > front (x <| s) == Just (x,s) +-- +-- [/front2/] +-- +-- > front (s |> x) == case front s of {Nothing -> Just (x, empty); Just (x',s') -> Just (x', s' |> x)} +-- +-- [/front3/] +-- +-- > front (s >< t) == case front s of {Nothing -> front t; Just (x',s') -> Just (x', s' >< t)} +-- +-- [/back0/] +-- +-- > back empty == Nothing +-- +-- [/back1/] +-- +-- > back (s |> x) == Just (s,x) +-- +-- [/back2/] +-- +-- > back (x <| s) == case back s of {Nothing -> Just (empty, x); Just (s',x') -> Just (x <| s', x')} +-- +-- [/back3/] +-- +-- > back (t >< s) == case back s of {Nothing -> back t; Just (s',x') -> Just (t >< s', x')} +-- +-- [/drop1/] +-- +-- > drop 0 s == s +-- +-- [/drop2/] +-- +-- > n>0 ==> drop (n+1) s == case front (drop n s) of Nothing -> empty; Just (_,s') -> s' +-- +-- [/take1/] +-- +-- > take 0 s == empty +-- +-- [/take2/] +-- +-- > n>0 ==> take (n+1) s == case front s of Nothing -> empty; Just (x,s') -> x <| take n s' +-- +-- [/reverse/] +-- +-- > foldMap f (reverse s) == getDual (foldMap (Dual . f) s) +-- +-- [/mempty/] +-- +-- > mempty == empty +-- +-- [/eq_fold/] +-- +-- > s1 == s2 ==> foldMap f s1 == foldMap f s2 + +sequence_properties :: forall s a . (Arbitrary s, Arbitrary a, + Show s, Show a, + Eq s, Eq a, + Sequence s a + ) => s -> [(Property,String)] +sequence_properties _ = [(property prop_fold0,"fold0"), (property prop_fold1,"fold1"), (property prop_fold2,"fold2"), (property prop_fold3,"fold3"), (property prop_front0,"front0"), (property prop_front1,"front1"), (property prop_front2,"front2"), (property prop_front3,"front3"), (property prop_back0,"back0"), (property prop_back1,"back1"), (property prop_back2,"back2"), (property prop_back3,"back3"), (property prop_drop1,"drop1"), (property prop_drop2,"drop2"), (property prop_take1,"take1"), (property prop_take2,"take2"), (property prop_reverse,"reverse"), (property prop_mempty,"mempty"), (property prop_eq_fold,"eq_fold")] + where + empty = C.empty :: s + front = C.front :: s -> Maybe (a,s) + back = C.back :: s -> Maybe (s,a) +-- size = C.size :: s -> Int + drop = C.drop :: Int -> s -> s + take = C.take :: Int -> s -> s + reverse = C.reverse :: s -> s + foldMap :: forall m. Monoid m => (a -> m) -> s -> m + foldMap = C.foldMap + + f :: a -> [a] -- testing this single function ensure that fold properties are ok for all monoids and functions + -- (because mappend is associative) + f x = [x] + + prop_fold0 = foldMap f empty == mempty + prop_fold1 s x = foldMap f (x <| s) == f x `mappend` foldMap f s + prop_fold2 s x = foldMap f (s |> x) == foldMap f s `mappend` f x + prop_fold3 s t = foldMap f (s >< t) == foldMap f s `mappend` foldMap f t + + prop_front0 = front empty == Nothing + prop_front1 s x = front (x <| s) == Just (x,s) + prop_front2 s x = front (s |> x) == case front s of {Nothing -> Just (x, empty); Just (x',s') -> Just (x', s' |> x)} + prop_front3 s t = front (s >< t) == case front s of {Nothing -> front t; Just (x',s') -> Just (x', s' >< t)} + + prop_back0 = back empty == Nothing + prop_back1 s x = back (s |> x) == Just (s,x) + prop_back2 s x = back (x <| s) == case back s of {Nothing -> Just (empty, x); Just (s',x') -> Just (x <| s', x')} + prop_back3 s t = back (t >< s) == case back s of {Nothing -> back t; Just (s',x') -> Just (t >< s', x')} + + prop_drop1 s = drop 0 s == s + prop_drop2 s n = n>0 ==> drop (n+1) s == case front (drop n s) of Nothing -> empty; Just (_,s') -> s' + + prop_take1 s = take 0 s == empty + prop_take2 s n = n>0 ==> take (n+1) s == case front s of Nothing -> empty; Just (x,s') -> x <| take n s' + + prop_reverse s = foldMap f (reverse s) == getDual (foldMap (Dual . f) s) + + prop_mempty = mempty == empty + + prop_eq_fold s1 s2 = s1 == s2 ==> foldMap f s1 == foldMap f s2 + +-- | indexed_sequence_properties returns the following properties: +-- +-- [/domain/] +-- +-- > k `inDomain` s <==> k >= 0 && k < size s +-- +-- [/left1/] +-- +-- > k `inDomain` s ==> index (k+1) (x <| s) == index k s +-- +-- [/left2/] +-- +-- > index 0 (x <| s) == x +-- +-- [/right1/] +-- +-- > k `inDomain` s ==> index k (s |> x) == index k s +-- +-- [/right2/] +-- +-- > index (size s) (s |> x) == x +-- +-- [/append1/] +-- +-- > k `inDomain` t ==> index (k+size s) (s >< t) == index k t +-- +-- [/append2/] +-- +-- > k `inDomain` s ==> index k (s >< t) == index k s + +indexed_sequence_properties :: forall s a . (Arbitrary s, Arbitrary a, + Show s, Show a, + Eq s, Eq a, + Sequence s a, + Indexed s Int a + ) => s -> [(Property,String)] +indexed_sequence_properties _ = [(property prop_domain,"domain"), (property prop_left1,"left1"), (property prop_left2,"left2"), (property prop_right1,"right1"), (property prop_right2,"right2"), (property prop_append1,"append1"), (property prop_append2,"append2")] + where + index = C.index :: Int -> s -> a + (<|) = (C.<|) :: a -> s -> s + (|>) = (C.|>) :: s -> a -> s + (><) = (C.><) :: s -> s -> s + inDomain = C.inDomain :: Int -> s -> Bool + + prop_domain k s = k `inDomain` s <==> k >= 0 && k < size s + + prop_left1 k s x = k `inDomain` s ==> index (k+1) (x <| s) == index k s + prop_left2 s x = index 0 (x <| s) == x + prop_right1 k s x = k `inDomain` s ==> index k (s |> x) == index k s + prop_right2 s x = index (size s) (s |> x) == x + prop_append1 k s t = k `inDomain` t ==> index (k+size s) (s >< t) == index k t + prop_append2 k s t = k `inDomain` s ==> index k (s >< t) == index k s + +-- | indexed_map_properties returns the following properties: +-- +-- [/domain/] +-- +-- > k `inDomain` m <==> k `member` m +-- +-- [/index/] +-- +-- > case lookup k m of {Just x -> x == index k m; _ -> True} + +indexed_map_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, + Map m k v, + Indexed m k v + ) => m -> [(Property,String)] +indexed_map_properties _ = [(property prop_domain,"domain"), (property prop_index,"index")] + where + index = C.index :: k -> m -> v + inDomain = C.inDomain :: k -> m -> Bool + prop_domain k m = k `inDomain` m <==> k `member` m + prop_index k m = case lookup k m of {Just x -> x == index k m; _ -> True} + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +See the AUTHORS file for a list of copyright holders. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of + other contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +import Distribution.Simple +main = defaultMain diff --git a/collections-api.cabal b/collections-api.cabal new file mode 100644 --- /dev/null +++ b/collections-api.cabal @@ -0,0 +1,27 @@ +name: collections-api +build-type: Simple +version: 1.0.0.0 +category: Data Structures + +license: BSD3 +license-file: LICENSE + +author: Jean-Philippe Bernardy +maintainer: jeanphilippe.bernardy (google mail) + +synopsis: API for collection data structures. +description: This package provides classes for a consistent API to data + structures. The behaviour of the interface is specified by QuickCheck properties. + It is intended as an evolution of the API of the data structures in the @containers@ package. +homepage: http://code.haskell.org/collections/ +cabal-version: >= 1.6 + +tested-with: GHC==6.12.1 + +exposed-modules: + Data.Collections, + Data.Collections.Foldable, + Data.Collections.Properties +build-depends: base >= 3 && < 5, QuickCheck == 2.*, array +extensions: CPP, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances +ghc-options: -Wall