CollectionClassFramework: Collections.hs

File Collections.hs, 18.5 KB (added by jpbernardy, 8 years ago)
Line 
1{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
2-----------------------------------------------------------------------------
3-- |
4-- Module      :  Data.Collections
5-- Copyright   :  (c) Jean-Philippe Bernardy 2006
6-- License     :  BSD-style
7-- Maintainer  :  jeanphilippe.bernardy; google mail.
8-- Stability   :  experimental
9-- Portability :  MPTC, FD, undecidable instances
10--
11-- Framework for collection types. It provides:
12--
13-- * Classes for the most common type of collections
14--
15-- * /View types/ to change the type of a collection, so it implements other classes.
16-- This allows to use types for purposes that they are not originally designed for. (eg. 'AssocView')
17--
18-- * A few generic functions for handling collections.
19--
20--
21--
22-- The classes defined in this module are intended to give hints about performance.
23-- eg. if a function has a @MapLike c k v@ context, this indicates that the function
24-- will perform better if @c@ has an efficitent lookup function.
25--
26-- This module name-clashes with a lot of Prelude functions, subsuming those.
27-- The user is encouraged to import Prelude hiding the clashing functions.
28-- Alternatively, it can be imported @qualified@.
29
30{-
31
32
33TODO:
34 * write instances for the new Seq type, following List.[]
35-- fix union comment. Better semantics generally.
36
37-- foldr/l in sequence
38
39 * See how the new Foldable class superseeds any of this. Remove stuff as needed.
40
41-}
42
43module Data.Collections 
44    (
45
46-- * Classes
47     Collection(..),
48     Indexed(..),
49     MapLike(..),
50     SetLike,
51     Sequence(..),
52
53-- * Extra generic functions
54     findWithDefault,
55     unions,
56
57-- ** Aliases
58     (\\),
59
60-- ** Unfolding
61     unfold,
62
63-- * Conversions
64     convert,
65     toList,
66     fromList,
67
68-- * Views
69     AssocView(..),
70     KeysView(..), ElemsView(..),
71             
72     Void
73    ) where 
74
75import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldl,null,reverse,(++))
76
77import Control.Monad
78import qualified Data.Map as Map
79import qualified Data.List as List
80import qualified Data.Set as Set
81import qualified Data.Array as Array
82import qualified Data.Maybe as Maybe
83
84infixl 9 !,\\ --
85
86-- | Type with no value; ideally it should be a strict type.
87data Void
88noVoidValue = error "Don't use bottom to populate the Nothing type."
89
90------------------------------------------------------------------------
91-- * Type classes
92
93-- | Class of collection types.
94--
95-- * 'i' values are inserted into the collection.
96--
97-- * 'o' values are extracted out of the collection.
98--
99-- Having two extra parameters allows for:
100--
101--  * unobservable collections when 'o' = @()@
102--
103--  * \"readonly\" collections when 'i' = 'Void'
104--
105--  * Views over only some projection of the element (see 'KeysView' and 'ElemsView')
106--
107-- Also, please note that:
108--
109--  * There is no notion of order in this class. ('fold', 'toList', etc. provide specific order no guarantee)
110--
111--  * neither 'map' nor 'fmap' is in here, use Functor for that purpose.
112--
113--  * @extract :: c -> Maybe (o,c)@ to take a random element is not there either.
114--- Use 'front', possibly converting to 'Data.List' if needed. (you don't know if the collection implements a fast linear access)
115
116class Collection c i o | c -> i o where
117    -- | The empty collection.
118    empty :: c                           
119    -- | Tells whether the collection contains a single element.
120    isSingleton :: c -> Bool             
121    -- | 'filter', applied to a predicate and a list, returns the collection of those elements that satisfy the predicate.
122    filter :: (o -> Bool) -> c -> c       
123    -- | \'natural\' traversal of all elements of a collection. No particular order is guaranteed.
124    fold :: (o -> b -> b) -> b -> c -> b 
125    -- | \'natural\' insertion into the collection.
126    fold' :: (o -> b -> b) -> b -> c -> b 
127    -- | \'natural\' insertion into the collection, in a strict fashion
128    insert :: i -> c -> c                 
129    -- | Tells whether the collection is empty
130    null :: c -> Bool                   
131    -- | Creates a collection with a single element.
132    singleton :: i -> c
133    -- | Returns the size of the collection
134    size :: c -> Int   
135   
136    isSingleton = (1 ==) . size           
137    singleton i = insert i empty
138    size = fold (const (+1)) 0
139
140unfold :: (Collection c a a) => (b -> Maybe (a, b)) -> b -> c
141unfold f s = convert $ List.unfoldr f s
142-- in the above List.unfoldr should be deforested away.
143
144-- | Conversion between two collection types.
145convert :: (Collection c i o, Collection c' o o) => c -> c'
146convert = fold insert empty
147
148-- | Converts a collection into a list.
149toList :: Collection c i o => c -> [o]
150toList = convert
151
152-- | Converts a list into a collection.
153fromList :: Collection c a a => [a] -> c
154fromList = convert
155
156
157-- | Class of sequential-access types.
158class Collection c i o => Sequence c i o where
159    foldl :: (b -> o -> b) -> b -> c -> b 
160    take :: Int -> c -> c         
161    drop :: Int -> c -> c
162    splitAt :: Int -> c -> (c,c)
163    reverse :: c -> c
164    front :: Monad m => c -> m (o,c)
165    back :: Monad m => c -> m (c,o)
166    (<|) :: i -> c -> c
167    (|>) :: c -> i -> c
168    (><) :: c -> c -> c
169
170foldr :: Sequence c i o => (o -> b -> b) -> b -> c -> b 
171foldr = fold
172
173
174-- | Class of indexed types.
175-- The collection is 'dense': there is no way to /remove/ an element nor for lookup
176-- to return "not found".
177--
178-- In practice however, most sparse poplutated indexed collection will instanciate this
179-- class, and leave the responsibility of failure to the caller.
180class Indexed c k v | c -> k v where
181    -- | @c!k@ returns element associated to 'k'
182    (!) :: c -> k -> v                 
183    -- | @adjust f k c@ applies 'f' to element associated to 'k'
184    adjust :: (v -> v) -> k -> c -> c
185
186
187-- TODO: bounds as in the class array would be a nice addition. However, this does not fit well with Map being an instance of Indexed.
188-- Have a separate class for that ?
189
190
191-- | Class of map-like types. (aka. for sparse associative types).
192--
193-- In opposition of Indexed, MapLike supports unexisting value for some indices.
194
195class MapLike c k a | c -> k a where
196    -- | Remove an element from the keySet.
197    delete :: k -> c -> c
198    delete = update (const Nothing)
199
200    -- | Tells whether an element is member of the keySet.
201    member :: k -> c -> Bool
202    member k = Maybe.isJust . lookup k
203
204    -- | Union of two keySets.
205    -- When duplicates are encountered, the elements may come from any of the two input sets.
206    --
207    -- values come from the map given as first arguement.
208    union :: c -> c -> c
209    union = unionWith const
210
211    -- | Difference of two keySets.
212    -- Difference is to be read infix: @a `difference` b@ returns a set containing the elements of @a@ that are also absent from @b@.
213    --
214    difference :: c -> c -> c
215    difference = differenceWith (\x y -> Nothing)
216
217    -- | Intersection of two keySets.
218    --
219    -- When duplicates are encountered, the elements may come from any of the two input sets.
220    -- Intersection is commutative: @intersection a b == intersection b a@
221    intersection :: c -> c -> c
222    intersection = intersectionWith const
223
224-- Follows functions for fully-fledged maps.
225
226                                                               
227    -- | Insert with a combining function.
228    --
229    -- @insertWith f key value m@
230    -- will insert the pair @(key, value)@ into @m@ if @key@ does
231    -- not exist in the map. If the key does exist, the function will
232    -- insert the pair @(key, f new_value old_value)@.
233    insertWith :: (a -> a -> a) -> k -> a -> c -> c
234    insertWith f k a c = update (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k c
235
236    -- | Union with a combining function.
237    unionWith :: (a -> a -> a) -> c -> c -> c
238
239    -- | Intersection with a combining function.
240    intersectionWith :: (a -> a -> a) -> c -> c -> c
241
242    -- | Difference with a combining function.
243    differenceWith  :: (a -> a -> Maybe a) -> c -> c -> c
244
245    -- NOTE: there's an infelicity here because Map difference has type:
246    -- Map k a -> Map k b -> Map k a -- (same infelicity for intersection)
247
248    -- | Lookup the value at a given key.
249    lookup :: Monad m => k -> c -> m a
250
251    -- | Change the value at a given key. Nothing represents no associated value.
252    update :: (Maybe a -> Maybe a) -> k -> c -> c
253
254-- | The expression @('findWithDefault' def k map)@ returns
255-- the value at key @k@ or returns @def@ when the key is not in the map.
256findWithDefault :: (MapLike c k a) => a -> k -> c -> a
257findWithDefault a k c = Maybe.fromMaybe a (lookup k c)
258
259
260
261-- | Class for set-like collection types. A set is really a map with no value associated to the keys,
262-- so SetLike just states so.
263--
264-- Note that this should be a context alias or something.
265class MapLike c k () => SetLike c k where
266    -- | Dummy method for haddock to accept the class.
267    haddock_candy :: c -> k
268
269-- | Difference of two (key) sets.
270(\\) :: MapLike c k a => c -> c -> c
271(\\) = difference
272
273
274-- | Union of many (key) sets.
275unions :: (Collection s i o, MapLike s k a, Collection cs i' s) => cs -> s
276unions sets = fold union empty sets
277
278-- NOTE: Should be specialized (RULE pragma) so it's not horribly inefficient in the common cases
279
280
281-----------------------------------------------------------------------------
282-- Instances
283-----------------------------------------------------------------------------
284
285
286-- We follow with (sample) instances of the classes.
287
288-----------------------------------------------------------------------------
289-- Data.List
290
291instance Collection [a] a a where
292    null = List.null
293    fold = List.foldr
294    fold' f = List.foldl' (flip f)
295    empty = []
296    singleton = return
297    insert = (:)
298    filter = List.filter
299
300instance Sequence [a] a a where
301    foldl = List.foldl
302    take = List.take
303    drop = List.drop
304    splitAt = List.splitAt
305    reverse = List.reverse
306    front (x:xs) = return (x,xs)
307    front [] = fail "front: empty sequence"
308    back s = return swap `ap` front (reverse s)
309        where swap (a,b) = (b,a)
310    (<|) = (:)
311    xs |> x = xs List.++ [x]
312    (><) = (List.++)
313
314(++) s1 s2 = (><) s1 s2
315-- Deprecate ?
316   
317-- For convenience, List is made and instance of Indexed.
318instance Indexed [a] Int a where
319    (!) = (List.!!)
320    adjust f k l = l >< (f x:r)
321        where (l,x:r) = List.splitAt (k-1) l
322
323
324-- For "compatibility" with the Prelude, List is made and instance of SetLike.
325-- This however conflicts with the below above declaration: Indexed [a] Int a.
326-- Note: I wonder how ghc can accept this.
327
328instance Eq a => SetLike [a] a where
329    haddock_candy = haddock_candy
330
331instance Eq a => MapLike [a] a () where
332    difference = (List.\\)
333    delete = List.delete
334    member = List.elem
335    union = List.union
336    intersection = List.intersect
337    insertWith f k () = insert k
338    unionWith f = union
339    intersectionWith f = intersection
340    differenceWith f = difference
341    lookup k l = if member k l then return () else fail "element not found"
342    update f k l = let lk = lookup k l in
343        case lk of
344           Nothing -> case lk of
345                         Nothing -> l
346                         Just _ -> insert k l
347           Just _ -> case lk of
348                         Nothing -> delete k l
349                         Just _ -> l
350   
351-- | View a list of @(key,value)@ pairs as a 'MapLike' collection.
352--
353-- This allows to feed sequences into algorithms that require a map without building a full-fledged map.
354-- Most of the time this will be used only when the parameter list is known to be very small, such that
355-- conversion to a Map would be to costly.
356
357newtype AssocView s k v = AssocView {fromAssocView :: s} -- k and v parameters will become useful if we generalize to sequences.
358
359association :: [(k,v)] -> AssocView [(k,v)] k v
360association = AssocView
361
362instance Collection (AssocView [(k,v)] k v) (k,v) (k,v) where
363    empty = AssocView []
364    fold f i (AssocView l) = fold f i l
365    fold' f i (AssocView l) = fold' f i l
366    null (AssocView l) = null l
367    filter f (AssocView l) = AssocView $ filter f l
368    insert x (AssocView l) = AssocView $ insert x l
369   
370instance Eq k => Indexed (AssocView [(k,v)] k v) k v where
371    (AssocView c) ! k = Maybe.fromJust (List.lookup k c)
372    adjust f k (AssocView c) = AssocView $ List.map (\a@(k',v) -> if k == k' then (k, f v) else a) c
373
374instance Eq k => MapLike (AssocView [(k,v)] k v) k v where
375    delete k c = update (const Nothing) k c
376    member k c = Maybe.isJust (lookup k c)
377    union = unionWith const
378    intersection = intersectionWith const
379    difference = differenceWith (\x y->Nothing)
380
381    lookup k (AssocView l) = if List.null result then fail "Key not found" else return . snd . head $ result
382        where result = [x | x <- l, fst x == k]
383    insertWith f k a c = 
384        case lookup k c of
385           Nothing -> insert (k,a) c
386           Just b -> insert (k, f a b) (delete k c)
387    intersectionWith f (AssocView m1) (AssocView m2) = AssocView [(k,f x y) 
388                                                                        | (k,x) <- m1, 
389                                                                           y <- Maybe.maybeToList $ List.lookup k m2]
390    unionWith f (AssocView m1) (AssocView m2) = AssocView $ List.map unionOne $ List.groupBy (testing fst) $ m1 >< m2
391        where unionOne list = (fst (head list), foldr1 f (List.map snd list))
392    differenceWith f (AssocView m1) (AssocView m2) = AssocView $ Maybe.catMaybes
393                                                         [newEl k x (List.lookup k m2) | (k,x) <- m1]
394        where newEl k x Nothing = Just (k,x)
395              newEl k x (Just y) = fmap (\x->(k,x)) (f x y)
396    update f k (AssocView m) = AssocView $ case f $ fmap snd $ Maybe.listToMaybe eq of
397                                              Nothing -> neq
398                                              Just x -> (k,x):neq
399        where (eq,neq) = List.partition (\x->fst x == k) m
400
401testing :: Eq b => (a -> b) -> a -> a -> Bool
402testing f x y = (==) (f x) (f y)
403
404
405--------------------------------------
406-- Data.Array
407
408instance Array.Ix i => Collection (Array.Array i e) Void (i,e) where   
409    fold f i c = List.foldr f i (Array.assocs c)
410    fold' f i c = List.foldl' (flip f) i (Array.assocs c)
411    insert = noVoidValue
412    filter = noVoidValue
413    empty = noVoidValue
414    null c = null $ Array.range $ Array.bounds c
415
416instance Array.Ix i => Indexed (Array.Array i e) i e where
417    (!) = (Array.!)
418    adjust f k a = a Array.// [(k,f (a!k))]
419
420-----------------------------------------------------------------------------
421-- Data.Map
422instance Ord k => Collection (Map.Map k a) (k,a) (k,a) where
423    filter f = Map.filterWithKey (curry f)
424    insert = uncurry Map.insert
425    null = Map.null
426    singleton (k,a) = Map.singleton k a
427    fold f i m = Map.foldWithKey (curry f) i m
428    empty = Map.empty
429
430instance Ord k => Indexed (Map.Map k a) k a where
431    (!) = (Map.!)
432    adjust = Map.adjust
433
434instance Ord k => MapLike (Map.Map k a) k a where
435    member = Map.member
436    union = Map.union
437    difference = Map.difference
438    delete = Map.delete
439    intersection = Map.intersection
440    lookup = Map.lookup
441    update f k m = case f (lookup k m) of
442                      Just a -> Map.insert k a m
443                      Nothing -> Map.delete k m
444             -- TODO: add support for this in Data.Map
445    insertWith = Map.insertWith
446    unionWith = Map.unionWith
447    intersectionWith = Map.intersectionWith
448    differenceWith = Map.differenceWith
449
450-----------------------------------------------------------------------------
451-- Data.Set
452
453instance Ord a => Collection (Set.Set a) a a where
454    filter = Set.filter
455    insert = Set.insert
456    null = Set.null
457    singleton = Set.singleton
458    fold f i s = Set.fold f i s
459    empty = Set.empty
460
461instance Ord a => SetLike (Set.Set a) a where
462    haddock_candy = haddock_candy
463
464instance Ord a => MapLike (Set.Set a) a () where
465    member = Set.member
466    union = Set.union
467    difference = Set.difference
468    intersection = Set.intersection
469    delete = Set.delete
470    insertWith f k () = insert k
471    unionWith f = union
472    intersectionWith f = intersection
473    differenceWith f = difference
474    lookup k l = if member k l then return () else fail "element not found"   
475    update f k m = case f (lookup k m) of
476                      Just a -> insert k m
477                      Nothing -> delete k m
478
479------------------------------------------------------------------------
480-- Trickier stuff for alternate dictionnary usages
481
482-- | "View" to the keys of a dictionnary
483newtype KeysView m k v = KeysView {fromKeysView :: m}
484
485-- | "View" to the elements of a dictionnary
486newtype ElemsView m k v = ElemsView {fromElemsView :: m}
487
488-- The following requires undecidable instances. An alternative
489-- implementation is to define these instances directly on the
490-- concrete map types and drop the requirement for the aforementioned
491-- extension.
492
493instance Collection m (k,v) (k,v) => Collection (KeysView m k v) (k,v) k where
494    empty = KeysView empty
495    filter f (KeysView m) = KeysView $ filter (f . fst) m
496    fold f i (KeysView c) = fold (f . fst) i c
497    fold' f i (KeysView c) = fold' (f . fst) i c
498    insert x (KeysView m) = KeysView $ insert x m
499    null (KeysView c) = null c
500    singleton x = KeysView (singleton x)
501   
502instance Collection m (k,v) (k,v) => Collection (ElemsView m k v) (k,v) v where
503    empty = ElemsView empty
504    filter f (ElemsView m) = ElemsView $ filter (f . snd) m
505    fold f i (ElemsView c) = fold (f . snd) i c
506    fold' f i (ElemsView c) = fold' (f . snd) i c
507    insert x (ElemsView m) = ElemsView $ insert x m
508    null (ElemsView c) = null c
509    singleton x = ElemsView (singleton x)
510 
511instance MapLike m k v => MapLike (KeysView m k v) k v where
512    member k (KeysView m) = Maybe.isJust $ lookup k m
513    union (KeysView m) (KeysView m') = KeysView $ union m m'
514    difference (KeysView m) (KeysView m') = KeysView $ difference m m'
515    intersection (KeysView m) (KeysView m') = KeysView $ intersection m m'
516    delete k (KeysView m) = KeysView $ delete k m
517    insertWith f k a (KeysView m) = KeysView $ insertWith f k a m
518    lookup k (KeysView m) = lookup k m
519    update f k (KeysView m) = KeysView $ update f k m
520    unionWith f (KeysView m) (KeysView m') = KeysView $ unionWith f m m'
521    differenceWith f (KeysView m) (KeysView m') = KeysView $ differenceWith f m m'
522    intersectionWith f (KeysView m) (KeysView m') = KeysView $ intersectionWith f m m'
523
524
525
526
527-----------------------------
528-- examples of use/test code
529
530sum c = fold (+) 0 c
531
532concat c = fold (><) [] c
533
534origList = [("one", 1), ("two", 2)]
535
536someMap :: Map.Map String Int
537someMap = convert origList
538 
539test1 = sum $ ElemsView someMap
540test1a = sum $ ElemsView origList
541
542test2 = concat $ KeysView someMap
543test2a = concat $ KeysView someMap
544
545test3 = someMap ! "one"
546test3a :: Int
547test3a = association origList ! "one"
548
549