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

module Data.Map.List (AssocList(..)) where

import Data.Monoid
import qualified Data.Maybe as Maybe
import qualified Data.List as List
import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldr1,foldl,null,reverse,(++),minimum,maximum,all,elem,concatMap,head)
import Data.Collections
import Data.Typeable
import Data.Ord (comparing)

-- | View a list (actually any 'Sequence') of @(key,value)@ pairs as a 'Map' collection.
-- This allows to feed sequences into algorithms that require a map without building a full-fledged map.
-- Most of the time this will be used only when the parameter list is known to be very small, such that
-- conversion to a Map would be to costly.

newtype AssocList s k v = AssocList s

-- FIXME: GHC 6.4 cannot see that Sequence c (k,v) implies the FD: c -> k v
-- Hence it requires two extra parameters to AssocList. Drop them as possible.

#include "Typeable.h"

instance (Eq c, Eq k, Eq v, Foldable c (k,v)) => Eq (AssocList c k v) where
    (AssocList l1) == (AssocList l2) = l1 == l2 || 
                                       (size l1 == size l2 && all (`elem` l1) l2)

instance Show l => Show (AssocList l k v) where
    show (AssocList l) = "AssocList " >< show l

instance Sequence c (k,v) => Foldable (AssocList c k v) (k,v) where
    foldr f z (AssocList l) = foldr f z l
    null (AssocList l) = null l

instance (Ord k, Sequence c (k,v)) => Collection (AssocList c k v) (k,v) where
    filter f (AssocList l) = AssocList $ filter f l

instance (Ord k, Sequence c (k,v)) => Unfoldable (AssocList c k v) (k,v) where
    empty = AssocList empty
    insert (k,v) m = insertWith const k v m
instance (Ord k, Sequence c (k,v)) => Indexed (AssocList c k v) k v where
    index k c = Maybe.fromJust $ lookup k c
    adjust f k c = alter (fmap f) k c
    inDomain = member

instance (Ord k, Sequence c (k,v)) => Monoid (AssocList c k v) where
     mempty = empty
     mappend = union

instance (Ord k, Sequence c (k,v), Monoid (AssocList c k v)) => Map (AssocList c k v) k v where
    isSubmapBy f c1 c2 = all (\(k,v) -> case lookup k c2 of
                                            Nothing -> False
                                            Just v' -> f v v') c1
    c1 `isSubset` c2 = all (`member` c2) (KeysView c1) 
    lookup k (AssocList l) = maybe (fail "Key not found") (return . snd) (find ((k ==) . fst) l)
    intersectionWith f (AssocList m1) m2 
        = AssocList $ fromList 
          [(k,f x y) | (k,x) <- toList m1, 
           y <- Maybe.maybeToList $ lookup k m2]

    unionWith f (AssocList m1) (AssocList m2) = AssocList $ fromList $ List.map unionOne $
                                                List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) $ toList (m1 >< m2)
        where unionOne list = (fst (head list), foldr1 f (List.map snd list))
    differenceWith f (AssocList m1) m2 = AssocList $ fromList $ Maybe.catMaybes 
                                         [newEl k x (lookup k m2) | (k,x) <- toList m1]
        where newEl k x Nothing = Just (k,x)
              newEl k x (Just y) = fmap (\x->(k,x)) (f x y)
    alter f k m@(AssocList l) = AssocList $ foldr construct 
                                (if member k m then empty else maybe empty (\x -> singleton (k,x)) (f Nothing)) l
        where construct :: (k,v) -> c -> c
              construct a@(k',x) l
                  | k'== k = case f (Just x) of 
                                 Nothing -> l
                                 Just x -> (k', x) <| l
                  | otherwise = a <| l
    mapWithKey f (AssocList l) = AssocList (smap l)
        where smap = foldr (\(k,x) s -> (k,f k x) <| s) mempty

on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c)
on op f x y = op (f x) (f y)