{-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction -Wall -fno-warn-missing-signatures #-}

module Data.GMap.AssocList where

import Data.GMap 
import qualified Data.List as L
import Data.Maybe(catMaybes,isNothing)
import Data.Ord
import GHC.Base

-- Unsorted assoc list with no duplicate keys
newtype AList k a = AL [(k,a)]

keyEq a b = (fst a) == (fst b)
keysOf = L.map fst
elemsAL = L.map snd
withKey k a = (k,a)

deleteByKey k = L.deleteBy keyEq (k,undefined)

-- Strictly evaluluate structure and keys but not elements.
force [] = []
force l@((k,_):rest) = k `seq` force rest `seq` l

seqMaybe Nothing b = b
seqMaybe (Just a) b = a `seq` b
	
al = AL . force

unboxInt (I# i) = i

instance Eq k => Map (AList k) k where
	
	empty = al []
	
	singleton k a = al [(k,a)]
	
	pair k1 k2 = 
		if 	k1 == k2
		then	Nothing
		else	Just $ \ a1 a2 -> al [(k1,a1),(k2,a2)]
		 
	status (AL []) = None
	status (AL [(k,a)]) = One k a
	status _ = Many
	
	addSize (AL as) = (+#) (unboxInt (L.length as))
	
	lookup k (AL as) = L.lookup k as
	
	alter f k (AL as) = 
		let 	ma = L.lookup k as
		in	case (ma, f ma) of
				(Nothing, Nothing) 	-> al as
				(Nothing, Just a) 	-> al $ (k,a):as
				(Just _, Nothing) 	-> al $ deleteByKey k as
				(Just _, Just a)	-> al $ ((k,a):) $ deleteByKey k as 
				
	vennMaybe f (AL as) (AL bs) =
		let	leftDiff = 	[ (k,a) | (k,a) <- as , isNothing (L.lookup k bs) ]
			rightDiff = 	[ (k,b) | (k,b) <- bs , isNothing (L.lookup k as) ]
			inter =	
				let 	ks = L.intersect (keysOf as) (keysOf bs)
					assoc k = do
						a <- L.lookup k as
						b <- L.lookup k bs
						value <- f a b
						return (k,value)
				in	catMaybes (L.map assoc ks)
		in	(al leftDiff,al inter,al rightDiff)
				
	disjointUnion (AL as) (AL bs) = al (as ++ bs)
		
	isSubsetOf (AL as) (AL bs) = L.all (flip L.elem (keysOf bs)) (keysOf as)
	 
	isSubmapOf f (AL as) (AL bs) = L.all (\ (k,a) -> (Just True) == (fmap (f a) $ L.lookup k bs)) as
	
	map f (AL as) = al $ L.map (\(k,a) -> (k,f a)) as
	map' f (AL as) = al $ L.map (\(k,a) -> let a' = f a in a' `seq` (k,a')) as
	
	mapMaybe f (AL as) = al $ catMaybes $ L.map (\(k,a) -> fmap (withKey k) $ f a ) as
	
	mapWithKey f (AL as) = al $ L.map (\ (k,a) -> (k,f k a)) as
	mapWithKey' f (AL as) = al $ L.map (\(k,a) -> let a' = f k a in a' `seq` (k,a')) as
	
	filter f (AL as) = al $ L.filter (f . snd) as
	
	foldElems f b (AL as) = L.foldr f b $ elemsAL as
	foldKeys f b (AL as) = L.foldr f b $ keysOf as
	foldAssocs f b (AL as) = L.foldr (\(k,a) acc -> f k a acc) b as 
	
	foldElems' f b (AL as) = L.foldl' (flip f) b $ elemsAL as
	foldKeys' f b (AL as) = L.foldl' (flip f) b $ keysOf as
	foldAssocs' f b (AL as) = L.foldl' (\acc (k,a) -> f k a acc) b as 
	
	foldElemsUInt f i (AL as) = fold i as
		where	fold i' []     = i'
			fold i' ((_,a):as') = fold (f a i') as'
	
	valid (AL as) = 
		if 	keysOf as == (L.nub $ keysOf as)
		then 	Nothing
		else	Just "Duplicate keys"
		
-- Sorted assoc list with no duplicate keys
-- The map argument is used to determine the ordering used
newtype SList (map :: * -> *) k a = SL [(k,a)] 

sl :: OrderedMap mp k => [(k,a)] -> SList mp k a
sl kas = 
    let mp :: SList mp k a -> (mp a)
        mp = undefined
        result = SL $ force $ L.sortBy (\ (k1,_) (k2,_) -> compareKey (mp result) k1 k2) kas
    in  result

instance (Eq k, Ord k, OrderedMap mp k) => Map (SList mp k) k where
	empty = SL []
	
	singleton k a = SL [(k,a)]
	
	pair k1 k2 = 
		if 	k1 == k2
		then	Nothing
		else	Just $ \ a1 a2 -> sl [(k1,a1),(k2,a2)]
		 
	status (SL []) = None
	status (SL [(k,a)]) = One k a
	status _ = Many
	
	addSize (SL as) = (+#) (unboxInt (L.length as))
	
	lookup k (SL as) = L.lookup k as
	
	alter f k (SL as) = 
		let 	ma = L.lookup k as
		in	case (ma, f ma) of
				(Nothing, Nothing) 	-> SL as
				(Nothing, Just a) 	-> sl $ (k,a):as
				(Just _, Nothing) 	-> SL $ deleteByKey k as
				(Just _, Just a)	-> sl $ ((k,a):) $ deleteByKey k as 
	
	vennMaybe f (SL as) (SL bs) =
		let	leftDiff = 	[ (k,a) | (k,a) <- as , isNothing (L.lookup k bs) ]
			rightDiff = 	[ (k,b) | (k,b) <- bs , isNothing (L.lookup k as) ]
			inter =	
				let 	ks = L.intersect (keysOf as) (keysOf bs)
					assoc k = do
						a <- L.lookup k as
						b <- L.lookup k bs
						value <- f a b
						return (k,value)
				in	catMaybes (L.map assoc ks)
		in	(sl leftDiff,sl inter,sl rightDiff)
				
	disjointUnion (SL as) (SL bs) = sl (as ++ bs)
		
	isSubsetOf (SL as) (SL bs) = L.all (flip L.elem (keysOf bs)) (keysOf as)  
	
	isSubmapOf f (SL as) (SL bs) = L.all (\ (k,a) -> (Just True) == (fmap (f a) $ L.lookup k bs)) as  
	
	map f (SL as) = sl $ L.map (\(k,a) -> (k,f a)) as
	map' f (SL as) = sl $ L.map (\(k,a) -> let a' = f a in a' `seq` (k,a')) as
	
	mapMaybe f (SL as) = sl $ catMaybes $ L.map (\(k,a) -> fmap (withKey k) $ f a ) as
	
	mapWithKey f (SL as) = sl $ L.map (\ (k,a) -> (k,f k a)) as
	mapWithKey' f (SL as) = sl $ L.map (\(k,a) -> let a' = f k a in a' `seq` (k,a')) as
	
	filter f (SL as) = SL $ L.filter (f . snd) as
	
	foldElems f b (SL as) = L.foldr f b $ elemsAL as
	foldKeys f b (SL as) = L.foldr f b $ keysOf as
	foldAssocs f b (SL as) = L.foldr (\(k,a) acc -> f k a acc) b as 
	
	foldElems' f b (SL as) = L.foldl' (flip f) b $ reverse $ elemsAL as
	foldKeys' f b (SL as) = L.foldl' (flip f) b $ reverse $ keysOf as
	foldAssocs' f b (SL as) = L.foldl' (\acc (k,a) -> f k a acc) b $ reverse as 
	
	foldElemsUInt f i (SL as) = fold i as
		where	fold i' []     = i'
			fold i' ((_,a):as') = fold (f a i') as'
	
	valid (SL as) 
		| keysOf as /= (L.nub $ keysOf as)	= Just "Duplicate keys"
		| keysOf as /= (L.sort $ keysOf as)	= Just "Unsorted"
		| otherwise				= Nothing
		
instance (Eq k, Ord k, OrderedMap mp k) => OrderedMap (SList mp k) k where
	
	compareKey sl = compareKey (mp sl)
	   where mp :: SList mp k a -> (mp a)
	         mp = undefined 
	
	foldAssocsAsc f b (SL as) = L.foldr (uncurry f) b as
	foldAssocsDesc f b (SL as) = L.foldr (uncurry f) b $ reverse as
	
	foldAssocsAsc' f b (SL as) = L.foldl' (flip $ uncurry f) b $ reverse as
	foldAssocsDesc' f b (SL as) = L.foldl' (flip $ uncurry f) b as
   	
-- A map type to tell SList to behave use standard Orderings
data ImaginaryOrdMap k a
instance Eq k => Map (ImaginaryOrdMap k) k
instance (Eq k, Ord k) => OrderedMap (ImaginaryOrdMap k) k where
    compareKey _ = compare

type OList k = SList (ImaginaryOrdMap k) k
	
	
-- instance (Eq k, Ord k) => OrdMap (SList k) k