content: -- |
  --   Module      :  Data.Edison.Assoc.Defaults
  --   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
  --   License     :  MIT; see COPYRIGHT file for terms and conditions
  --
  --   Maintainer  :  robdockins AT fastmail DOT fm
  --   Stability   :  internal (unstable)
  --   Portability :  GHC, Hugs (MPTC and FD)
  --
  --   This module provides default implementations of many of the associative
  --   collection operations.  These function are used to fill in collection
  --   implementations and are not intended to be used directly by end users.
  
  module Data.Edison.Assoc.Defaults where
  
  import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter)
  
  import qualified Control.Monad.Fail as Fail
  
  import Data.Edison.Assoc
  import qualified Data.Edison.Seq as S
  import qualified Data.Edison.Seq.ListSeq as L
  import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)
  
  singletonUsingInsert :: (Assoc m k) => k -> a -> m a
  singletonUsingInsert k v = insert k v empty
  
  fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a
  fromSeqUsingInsertSeq kvs = insertSeq kvs empty
  
  insertSeqUsingFoldr ::
      (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a
  insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs
  
  unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a
  unionSeqUsingReduce ms = S.reducel union empty ms
  
  deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a
  deleteSeqUsingFoldr ks m = S.foldr delete m ks
  
  memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool
  memberUsingLookupM k m
    = case lookupM k m of
          Just _  -> True
          Nothing -> False
  
  countUsingMember :: AssocX m k => k -> m a -> Int
  countUsingMember k m = if member k m then 1 else 0
  
  lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a
  lookupAllUsingLookupM k m = case lookupM k m of
                                Just x -> S.singleton x
                                Nothing -> S.empty
  
  lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a
  lookupWithDefaultUsingLookupM d k m = case lookupM k m of
                                          Just x -> x
                                          Nothing -> d
  
  partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a)
  partitionUsingFilter f m = (filter f m, filter (not . f) m)
  
  fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a
  fold1UsingElements op m = L.foldr1 op (elements m)
  
  elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a
  elementsUsingFold = fold S.lcons S.empty
  
  nullUsingElements :: (AssocX m k) => m a -> Bool
  nullUsingElements m
    = case elements m of
          [] -> True
          _  -> False
  
  insertWithUsingLookupM ::
      FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a
  insertWithUsingLookupM f k x m =
      case lookupM k m of
        Nothing -> insert k x m
        Just y  -> insert k (f x y) m
  
  fromSeqWithUsingInsertSeqWith ::
      (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a
  fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty
  
  fromSeqWithKeyUsingInsertSeqWithKey ::
      (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a
  fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty
  
  insertWithKeyUsingInsertWith ::
      FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a
  insertWithKeyUsingInsertWith f k = insertWith (f k) k
  
  insertSeqWithUsingInsertWith ::
      (FiniteMapX m k,S.Sequence seq) =>
        (a -> a -> a) -> seq (k,a) -> m a -> m a
  insertSeqWithUsingInsertWith f kvs m =
      S.foldr (uncurry (insertWith f)) m kvs
  
  insertSeqWithKeyUsingInsertWithKey ::
      (FiniteMapX m k,S.Sequence seq) =>
        (k -> a -> a -> a) -> seq (k,a) -> m a -> m a
  insertSeqWithKeyUsingInsertWithKey f kvs m =
      S.foldr (uncurry (insertWithKey f)) m kvs
  
  unionSeqWithUsingReduce ::
      (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a
  unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms
  
  unionSeqWithUsingFoldr ::
      (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a
  unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms
  
  toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a)
  toSeqUsingFoldWithKey = foldWithKey conspair S.empty
    where conspair k v kvs = S.lcons (k,v) kvs
  
  keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k
  keysUsingFoldWithKey = foldWithKey conskey S.empty
    where conskey k _ ks = S.lcons k ks
  
  unionWithUsingInsertWith ::
      FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a
  unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1
  
  unionWithKeyUsingInsertWithKey ::
      FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a
  unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1
  
  unionSeqWithKeyUsingReduce ::
      (FiniteMap m k,S.Sequence seq) =>
        (k -> a -> a -> a) -> seq (m a) -> m a
  unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms
  
  unionSeqWithKeyUsingFoldr ::
      (FiniteMap m k,S.Sequence seq) =>
        (k -> a -> a -> a) -> seq (m a) -> m a
  unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms
  
  intersectionWithUsingLookupM ::
      FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c
  intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1
    where ins k x m = case lookupM k m2 of
                        Nothing -> m
                        Just y  -> insert k (f x y) m
  
  intersectionWithKeyUsingLookupM ::
      FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c
  intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1
    where ins k x m = case lookupM k m2 of
                        Nothing -> m
                        Just y  -> insert k (f k x y) m
  
  differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a
  differenceUsingDelete m1 m2 = foldWithKey del m1 m2
    where del k _ m = delete k m
  
  properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool
  properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2
  
  subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool
  subsetUsingMember m1 m2 = foldWithKey mem True m1
    where mem k _ b = member k m2 && b
  
  submapByUsingLookupM :: FiniteMap m k
                       => (a -> a -> Bool) -> m a -> m a -> Bool
  submapByUsingLookupM  f m1 m2 = foldWithKey aux True m1
    where aux k x b =
            case lookupM k m2 of
               Nothing -> False
               Just y  -> f x y && b
  
  properSubmapByUsingSubmapBy :: FiniteMapX m k
                              => (a -> a -> Bool) -> m a -> m a -> Bool
  properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2
  
  sameMapByUsingOrdLists :: OrdFiniteMap m k
                         => (a -> a -> Bool) -> m a -> m a -> Bool
  sameMapByUsingOrdLists f m1 m2 =
     let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2
     in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2))
  
  
  sameMapByUsingSubmapBy :: FiniteMapX m k
                         => (a -> a -> Bool) -> m a -> m a -> Bool
  sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2
  
  
  lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a)
  lookupAndDeleteDefault k m =
    case lookupM k m of
       Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed")
       Just x  -> (x, delete k m)
  
  lookupAndDeleteMDefault :: (Fail.MonadFail rm, AssocX m k) => k -> m a -> rm (a, m a)
  lookupAndDeleteMDefault k m =
    case lookupM k m of
       Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed")
       Just x  -> return (x, delete k m)
  
  lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a)
  lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m)
  
  adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a
  adjustOrInsertUsingMember f z k m =
    if member k m
       then adjust f k m
       else insert k z m
  
  adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a
  adjustOrDeleteDefault f k m =
    case lookupAndDeleteM k m of
      Nothing -> m
      Just (element,m') ->
        case f element of
           Nothing -> m'
           Just x  -> insert k x m'
  
  adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a
  adjustOrDeleteAllDefault f k m =
    let (elems,m') = lookupAndDeleteAll k m
        adjSeq = S.map f elems
        ins Nothing  n = n
        ins (Just x) n = insert k x n
    in L.foldr ins m' adjSeq
  
  minElemUsingMinView :: OrdAssocX m k => m a -> a
  minElemUsingMinView fm =
    case minView fm of
       Nothing    -> error $ (instanceName fm)++".minElem: empty map"
       Just (x,_) -> x
  
  deleteMinUsingMinView :: OrdAssocX m k => m a -> m a
  deleteMinUsingMinView fm =
    case minView fm of
       Nothing    -> error $ (instanceName fm)++".deleteMin: empty map"
       Just (_,m) -> m
  
  minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a)
  minElemWithKeyUsingMinViewWithKey fm =
    case minViewWithKey fm of
       Nothing    -> error $ (instanceName fm)++".minElemWithKey: empty map"
       Just (x,_) -> x
  
  maxElemUsingMaxView :: OrdAssocX m k => m a -> a
  maxElemUsingMaxView fm =
    case maxView fm of
       Nothing    -> error $ (instanceName fm)++".maxElem: empty map"
       Just (x,_) -> x
  
  deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a
  deleteMaxUsingMaxView fm =
    case maxView fm of
       Nothing    -> error $ (instanceName fm)++".deleteMax: empty map"
       Just (_,m) -> m
  
  maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a)
  maxElemWithKeyUsingMaxViewWithKey fm =
    case maxViewWithKey fm of
       Nothing    -> error $ (instanceName fm)++".maxElemWithKey: empty map"
       Just (x,_) -> x
  
  toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a)
  toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty
  
  showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS
  showsPrecUsingToList i xs rest
     | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]
     | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]
  
  readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a)
  readsPrecUsingFromList _ xs =
     let result = maybeParens p xs
         p ys = tokenMatch ((instanceName x)++".fromSeq") ys
                  >>= readsPrec 10
                  >>= \(l,rest) -> return (fromList l,rest)
  
         -- play games with the typechecker so we don't have to use
         -- extensions for scoped type variables
         ~[(x,_)] = result
  
     in result
  
  showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS
  showsPrecUsingToOrdList i xs rest
     | i == 0    = concat [    instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest]
     | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)]
  
  readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a)
  readsPrecUsingUnsafeFromOrdSeq i xs =
     let result = maybeParens p xs
         p ys = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") ys
                  >>= readsPrec i
                  >>= \(l,rest) -> return (unsafeFromOrdList l,rest)
  
         -- play games with the typechecker so we don't have to use
         -- extensions for scoped type variables
         ~[(x,_)] = result
  
     in result
  
  compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering
  compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys)
   where
    cmp [] [] = EQ
    cmp [] _  = LT
    cmp _  [] = GT
    cmp (v:vs) (z:zs) =
        case compare v z of
           EQ -> cmp vs zs
           c -> c
  