{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Collections
-- Copyright   :  (c) Jean-Philippe Bernardy, 2006
-- License     :  BSD3
-- Maintainer  :  jeanphilippe.bernardy; google mail.
-- Stability   :  experimental
-- Portability :  MPTC, FD, undecidable instances
--
-- 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/\".
-- <http://research.microsoft.com/Users/simonpj/Papers/collections.ps.gz>
-- 
-- 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(..),
-- ** 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,

-- * Concrete collection types
    Seq.Seq, 
    IntMap.IntMap, IntSet.IntSet,
    StdSet, StdMap, AvlSet, AvlMap, RangedSet
    ) 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 Control.Monad
import Data.Monoid
import Data.Collections.Foldable

import Data.Sequence (ViewL(..), ViewR(..))
import qualified Data.Sequence as Seq
import qualified Data.Foldable as AltFoldable

import qualified Data.Array as Array
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Set.AVL as AvlSet
import qualified Data.Map.AVL as AvlMap
import qualified Data.Set.Enum as EnumSet
import qualified Data.ByteString as BS
import qualified Data.Ranged as Ranged
import Data.Ranged (DiscreteOrdered)
--import qualified Data.ByteString.Char8 as BSC 
-- Char8 version cannot be made as long as all bytestrings use the same type.
import qualified Data.ByteString.Lazy as BSL
import Data.Word (Word8)
-- import Data.Int (Int64)
-- import Control.Monad.Identity

type StdSet = Set.Set
type StdMap = Map.Map
type AvlSet = AvlSet.Set
type AvlMap = AvlMap.Map
type RangedSet = Ranged.RSet

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 :: Monad m => c -> m (o,c)
    -- maxView :: Monad m => c -> m (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 :: Monad m => c -> m (a,c)
    -- | Analyse the right end of a sequence.
    back :: Monad m => c -> m (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)

-- Follows functions for fully-fledged maps.
    -- | Lookup the value at a given key.
    lookup :: Monad m => k -> c -> m 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 f (lookup k m) of
                    Just a -> insertWith (\x _->x) k a m
                    Nothing -> delete k 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
     

-- | 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

-----------------------------------------------------------------------------
-- Instances
-----------------------------------------------------------------------------


-- We follow with (sample) instances of the classes.

-----------------------------------------------------------------------------
-- Data.List

instance Unfoldable [a] a where
    empty = []
    singleton = return
    insert = (:)

instance Collection [a] a where
    filter = List.filter

instance Sequence [a] a where
    take = List.take
    drop = List.drop
    splitAt = List.splitAt
    reverse = List.reverse
    front (x:xs) = return (x,xs)
    front [] = fail "front: empty sequence"
    back s = return swap `ap` front (reverse s)
        where swap (x,s) = (reverse s,x)
    cons = (:)
    snoc xs x = xs List.++ [x]
    isPrefix = List.isPrefixOf

instance Indexed [a] Int a where
    index = flip (List.!!)
    adjust f k l = left >< (f x:right)
        where (left,x:right) = List.splitAt k l
    inDomain k l = k >= 0 && k < List.length l
    
--------------------------------------
-- Data.Sequence

instance Unfoldable (Seq.Seq a) a where
    empty = Seq.empty
    singleton = return
    insert = (<|)

instance Foldable (Seq.Seq a) a where
    foldr = AltFoldable.foldr
    foldl = AltFoldable.foldl
    foldr1 = AltFoldable.foldr1
    foldl1 = AltFoldable.foldl1
    foldMap = AltFoldable.foldMap
    null = Seq.null

instance Collection (Seq.Seq a) a where
    filter f = fromList . filter f . fromFoldable    

instance Sequence (Seq.Seq a) a where
    take = Seq.take
    drop = Seq.drop
    splitAt = Seq.splitAt
    reverse = Seq.reverse
    front s = case Seq.viewl s of
                EmptyL -> fail "front: empty sequence"
                a :< s -> return (a,s)
    back s = case Seq.viewr s of
                EmptyR -> fail "back: empty sequence"
                s :> a -> return (s,a)
    cons = (Seq.<|)
    snoc = (Seq.|>)

instance Indexed (Seq.Seq a) Int a where
    index = flip Seq.index
    adjust = Seq.adjust
    inDomain k l = k >= 0 && k < Seq.length l

------------------------
-- Data.ByteString

instance Foldable BS.ByteString Word8 where
    fold = foldr (+) 0
    foldr = BS.foldr
    foldl = BS.foldl
    foldr1 = BS.foldr1
    foldl1 = BS.foldl1
    null = BS.null
    size = BS.length

instance Unfoldable BS.ByteString Word8 where
    empty = BS.empty
    singleton = BS.singleton
    insert = BS.cons    

instance Collection BS.ByteString Word8 where
    filter = BS.filter

instance Sequence BS.ByteString Word8 where
    take = BS.take
    drop = BS.drop
    splitAt = BS.splitAt
    reverse = BS.reverse
    front s = if BS.null s then fail "front: empty ByteString" else return (BS.head s,BS.tail s)
    back s = if BS.null s 
             then fail "back: empty sequence" 
             else let (s',x) = BS.splitAt (BS.length s - 1) s in return (s', BS.head x)
    cons = BS.cons
    snoc = BS.snoc

instance Indexed BS.ByteString Int Word8  where
    index = flip BS.index
    adjust = error "Indexed.ajust: not supported by ByteString"
    inDomain k l = k >= 0 && k < BS.length l

------------------------
-- Data.ByteString.Lazy

instance Foldable BSL.ByteString Word8 where
    fold = foldr (+) 0
    foldr = BSL.foldr
    foldl = BSL.foldl
    foldr1 = BSL.foldr1
    foldl1 = BSL.foldl1
    null = BSL.null
    size = fromIntegral . BSL.length

instance Unfoldable BSL.ByteString Word8 where
    empty = BSL.empty
    singleton = BSL.singleton
    insert = BSL.cons
    
instance Collection BSL.ByteString Word8 where
    filter = BSL.filter

instance Sequence BSL.ByteString Word8 where
    take = BSL.take . fromIntegral
    drop = BSL.drop . fromIntegral
    splitAt = BSL.splitAt . fromIntegral
    reverse = BSL.reverse
    front s = if BSL.null s then fail "front: empty ByteString" else return (BSL.head s,BSL.tail s)
    back s = if BSL.null s 
             then fail "back: empty sequence" 
             else let (s',x) = BSL.splitAt (BSL.length s - 1) s in return (s', BSL.head x)
    cons = BSL.cons
    snoc = BSL.snoc

instance Indexed BSL.ByteString Int Word8  where
    index = flip BSL.index . fromIntegral
    adjust = error "Indexed.ajust: not supported by ByteString.Lazy yet"
    inDomain k l = k >= 0 && k < size l

--------------------------------------
-- Data.Array

instance Array.Ix i => Indexed (Array.Array i e) i e where
    index = flip (Array.!)
    adjust f k a = a Array.// [(k,f (a ! k))]
    inDomain k a = Array.inRange (Array.bounds a) k
    (//) a l = (Array.//) a (toList l)

instance Array.Ix i => Array (Array.Array i e) i e where
    array b l = Array.array b (toList l)
    bounds = Array.bounds

-----------------------------------------------------------------------------
-- Data.Map

-- TODO: write the instance based on foldMap
instance Foldable (Map.Map k a) (k,a) where
    foldr f i m = Map.foldWithKey (curry f) i m
    null = Map.null

instance Ord k => Unfoldable (Map.Map k a) (k,a) where
    insert = uncurry Map.insert
    singleton (k,a) = Map.singleton k a
    empty = Map.empty

instance Ord k => Collection (Map.Map k a) (k,a) where
    filter f = Map.filterWithKey (curry f)

instance Ord k => Indexed (Map.Map k a) k a where
    index = flip (Map.!)
    adjust = Map.adjust
    inDomain = member

instance Ord k => Map (Map.Map k a) k a where    
    isSubmapBy = Map.isSubmapOfBy
    isSubset = Map.isSubmapOfBy (\_ _->True)
    member = Map.member
    union = Map.union
    difference = Map.difference
    delete = Map.delete
    intersection = Map.intersection
    lookup x y = lifted $ Map.lookup x y
    alter = Map.alter
    insertWith = Map.insertWith
    unionWith = Map.unionWith
    intersectionWith = Map.intersectionWith
    differenceWith = Map.differenceWith
    mapWithKey = Map.mapWithKey

instance Ord k => SortingCollection (Map.Map k a) (k,a) where
    minView x = lifted $ Map.minViewWithKey x
        where swap (x,y) = (y,x)

lifted :: Monad m => Maybe a -> m a
lifted action = 
    case action of Nothing -> fail "missing key (probably)" ; Just x -> return x

-----------------------------------------------------------------------------
-- Data.AvlMap
instance Foldable (AvlMap.Map k a) (k,a) where
    foldr f i m = AvlMap.foldWithKey (curry f) i m
    null = AvlMap.null

instance Ord k => Unfoldable (AvlMap.Map k a) (k,a) where
    insert = uncurry AvlMap.insert
    singleton (k,a) = AvlMap.singleton k a
    empty = AvlMap.empty

instance Ord k => Collection (AvlMap.Map k a) (k,a) where
    filter f = AvlMap.filterWithKey (curry f)

instance Ord k => Indexed (AvlMap.Map k a) k a where
    index = flip (AvlMap.!)
    adjust = AvlMap.adjust
    inDomain = member

instance Ord k => Map (AvlMap.Map k a) k a where
    isSubmapBy = AvlMap.isSubmapOfBy
    isSubset = AvlMap.isSubmapOfBy (\_ _->True)
    member = AvlMap.member
    union = AvlMap.union
    difference = AvlMap.difference
    delete = AvlMap.delete
    intersection = AvlMap.intersection
    lookup = AvlMap.lookup
    alter = AvlMap.alter
    insertWith = AvlMap.insertWith
    unionWith = AvlMap.unionWith
    intersectionWith = AvlMap.intersectionWith
    differenceWith = AvlMap.differenceWith
    mapWithKey = AvlMap.mapWithKey

instance Ord k => SortingCollection (AvlMap.Map k a) (k,a) where
    minView c = if null c then fail "Data.AVL.Map.minView: empty map" else return (AvlMap.findMin c, AvlMap.deleteMin c)
    -- FIXME: add support for this in AvlMap.Map 


-----------------------------------------------------------------------------
-- Data.IntMap
instance Foldable (IntMap.IntMap a) (Int,a) where
    null = IntMap.null
    size = IntMap.size
    foldr f i m = IntMap.foldWithKey (curry f) i m

instance Unfoldable (IntMap.IntMap a) (Int,a) where
    insert = uncurry IntMap.insert
    singleton (k,a) = IntMap.singleton k a
    empty = IntMap.empty

instance Collection (IntMap.IntMap a) (Int,a) where
    filter f = IntMap.filterWithKey (curry f)

instance Indexed (IntMap.IntMap a) Int a where
    index = flip (IntMap.!)
    adjust = IntMap.adjust
    inDomain = member

instance Map (IntMap.IntMap a) Int a where
    isSubmapBy = IntMap.isSubmapOfBy
    isSubset = IntMap.isSubmapOfBy (\_ _->True)
    member = IntMap.member
    union = IntMap.union
    difference = IntMap.difference
    delete = IntMap.delete
    intersection = IntMap.intersection
    lookup x y = lifted $ IntMap.lookup x y
    alter = IntMap.alter
    insertWith = IntMap.insertWith
    unionWith = IntMap.unionWith
    intersectionWith = IntMap.intersectionWith
    differenceWith = IntMap.differenceWith
    mapWithKey = IntMap.mapWithKey

-----------------------------------------------------------------------------
-- Data.Set

instance Foldable (Set.Set a) a where
    foldr f i s = Set.fold f i s
    null = Set.null
    size = Set.size

instance Ord a => Unfoldable (Set.Set a) a where
    insert = Set.insert
    singleton = Set.singleton
    empty = Set.empty
    
instance Ord a => Collection (Set.Set a) a where
    filter = Set.filter

instance Ord a => Set (Set.Set a) a where
    haddock_candy = haddock_candy

instance Ord a => Map (Set.Set a) a () where
    isSubset = Set.isSubsetOf
    isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y))
    member = Set.member
    union = Set.union
    difference = Set.difference
    intersection = Set.intersection
    delete = Set.delete
    insertWith _f k () = insert k
    unionWith _f = union
    intersectionWith _f = intersection
    differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1
    lookup k l = if member k l then return () else fail "element not found"
    alter f k m = case f (lookup k m) of
                      Just _ -> insert k m
                      Nothing -> delete k m
    mapWithKey _f = id 


instance Ord a => SortingCollection (Set.Set a) a where
    minView c = if null c then fail "Data.Set.minView: empty set" else return (Set.findMin c, Set.deleteMin c)
    -- FIXME: add support for this in Data.Set

--------------------------------------
---------------------------------------
-- AvlSet

instance Foldable (AvlSet.Set a) a where
    foldr f i s = AvlSet.fold f i s
    null = AvlSet.null

instance Ord a => Unfoldable (AvlSet.Set a) a where
    insert = AvlSet.insert
    singleton = AvlSet.singleton
    empty = AvlSet.empty
    
instance Ord a => Collection (AvlSet.Set a) a where
    filter = AvlSet.filter

instance Ord a => Set (AvlSet.Set a) a where
    haddock_candy = haddock_candy

instance Ord a => Map (AvlSet.Set a) a () where
    isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y))
    isSubset = AvlSet.isSubsetOf
    member = AvlSet.member
    union = AvlSet.union
    difference = AvlSet.difference
    intersection = AvlSet.intersection
    delete = AvlSet.delete
    insertWith _f k () = insert k
    unionWith _f = union
    intersectionWith _f = intersection
    differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1
    lookup k l = if member k l then return () else fail "element not found"    
    alter f k m = case f (lookup k m) of
                      Just _ -> insert k m
                      Nothing -> delete k m
    mapWithKey _f = id

instance Ord a => SortingCollection (AvlSet.Set a) a where
    minView c = if null c then fail "Data.AVL.Set.minView: empty map" else return (AvlSet.findMin c, AvlSet.deleteMin c)
    -- FIXME: add support for this in Data.Map 


-----------------------------------------------------------------------------
-- Data.IntSet

instance Foldable IntSet.IntSet Int where
    foldr f i s = IntSet.fold f i s
    fold = foldl (+) 0
    null = IntSet.null
    size = IntSet.size

instance Unfoldable IntSet.IntSet Int where
    insert = IntSet.insert
    singleton = IntSet.singleton
    empty = IntSet.empty

instance Collection IntSet.IntSet Int where
    filter = IntSet.filter

instance Set IntSet.IntSet Int where
    haddock_candy = haddock_candy

instance Map IntSet.IntSet Int () where
    isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y))
    isSubset = IntSet.isSubsetOf
    member = IntSet.member
    union = IntSet.union
    difference = IntSet.difference
    intersection = IntSet.intersection
    delete = IntSet.delete
    insertWith _f k () = insert k
    unionWith _f = union
    intersectionWith _f = intersection
    differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1
    lookup k l = if member k l then return () else fail "element not found"    
    alter f k m = case f (lookup k m) of
                      Just _ -> insert k m
                      Nothing -> delete k m
    mapWithKey _f = id

-----------------------------------------------------------------------------
-- Data.EnumSet

instance Enum a => Foldable (EnumSet.Set a) a where
    foldr f i s = EnumSet.foldr f i s
    null = EnumSet.null
    size = EnumSet.size

instance Enum a => Unfoldable (EnumSet.Set a) a where
    insert = EnumSet.insert
    singleton = EnumSet.singleton
    empty = EnumSet.empty
    
instance Enum a => Collection (EnumSet.Set a) a where
    filter = EnumSet.filter

instance Enum a => Set (EnumSet.Set a) a where
    haddock_candy = haddock_candy

instance Enum a => Map (EnumSet.Set a) a () where
    isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y))
    isSubset = EnumSet.isSubsetOf
    member = EnumSet.member
    union = EnumSet.union
    difference = EnumSet.difference
    intersection = EnumSet.intersection
    delete = EnumSet.delete
    insertWith _f k () = insert k
    unionWith _f = union
    intersectionWith _f = intersection
    differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1
    lookup k l = if member k l then return () else fail "element not found"    
    alter f k m = case f (lookup k m) of
                      Just _ -> insert k m
                      Nothing -> delete k m
    mapWithKey _f = id

-------------------
-- Data.Ranged

instance DiscreteOrdered a => Unfoldable (RangedSet a) a where
    insert x =  Ranged.rSetUnion (Ranged.rSingleton x)
    singleton = Ranged.rSingleton
    empty = Ranged.rSetEmpty

instance DiscreteOrdered a => Map (RangedSet a) a () where
    isSubset = Ranged.rSetIsSubset
    isSubmapBy f x y = isSubset x y && (f () () || Ranged.rSetIsEmpty (intersection x y))
    member = flip Ranged.rSetHas
    union = Ranged.rSetUnion
    difference = Ranged.rSetDifference
    intersection = Ranged.rSetIntersection
    delete = flip Ranged.rSetDifference . Ranged.rSingleton
    insertWith _f k () = insert k
    unionWith _f = union
    intersectionWith _f = intersection
    differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1
    lookup k l = if member k l then return () else fail "element not found"
    alter f k m = case f (lookup k m) of
                      Just _ -> insert k m
                      Nothing -> delete k m
    mapWithKey _f = id 

instance DiscreteOrdered a => Set (RangedSet a) a where
    haddock_candy = haddock_candy

------------------------------------------------------------------------
-- 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'
    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