{-#OPTIONS -fglasgow-exts #-}
module GenMap where

{-
derives heavily from Ralf Hinze's "Generics for the masses"
<http://www.informatik.uni-bonn.de/~ralf/publications.html#P21>
-}


import Prelude hiding (lookup)
import qualified Data.Map as Prim
import qualified Data.IntMap as Patricia


__ = undefined

data EP  a b = EP { to :: a -> b, from :: b -> a }
type FEP f g = forall a. EP (f a) (g a)

idEP = EP id id

newtype Comp f g a = C { unC :: f (g a) }
data    Pair f g a = f a :*: g a

fold (*) f g (x :*: y) = f x * g y
proj1 (x :*: y) = x            -- proj1  = fold const id id
proj2 (x :*: y) = y            -- proj2  = fold (const id) id id
map1 f (x :*: y) = f x :*: y   -- map1 f = fold (:*:) f id
map2 f (x :*: y) = x :*: f y   -- map2 f = fold (:*:) id f


class Map k m | k -> m where
	func :: (MapFunc g) => g k m

class MapFunc g where
	unit     :: g () Maybe
	pair     :: (Map k1 m1, Map k2 m2) => g (k1,k2) (Comp m1 m2)
	plus     :: (Map k1 m1, Map k2 m2) => g (Either k1 k2) (Pair m1 m2)
	datatype :: (Map k' m') => EP k k' -> FEP m m' -> g k m
	prim     :: (Ord k) => g k (Prim.Map k)
	int      :: g Int Patricia.IntMap

instance Map () Maybe where func = unit
instance (Map k1 m1, Map k2 m2) => Map (k1,k2) (Comp m1 m2) where func = pair
instance (Map k1 m1, Map k2 m2) => Map (Either k1 k2) (Pair m1 m2) where func = plus

instance Map Int Patricia.IntMap where func = int
instance Map Char (Prim.Map Char) where func = prim

----

newtype Trie m a = Trie { unTrie :: Pair Maybe (Comp m (Trie m)) a }

instance (Map k m) => Map [k] (Trie m) where
	func = datatype (EP to from) (EP unTrie Trie)
		where
			to []     = Left ()
			to (x:xs) = Right (x,xs)
			
			from (Left ())      = []
			from (Right (x,xs)) = x:xs

type Dict = Trie (Prim.Map Char)

--

data Name = Uri String | Lit String String | Dat String String

type NameMap = Pair Dict (Pair (Comp Dict Dict) (Comp Dict Dict))
-- more readable: Dict :*: Dict :@: Dict :*: Dict :@: Dict

-- can you do this?

instance Map Name NameMap where
	func = datatype (EP to from) idEP
		where
			to (Uri u)   = Left u
			to (Lit s l) = Right (Left (s,l))
			to (Dat u s) = Right (Right (u,s))
			
			from (Left u)              = Uri u
			from (Right (Left (s,l)))  = (Lit s l)
			from (Right (Right (u,s))) = Dat u s



newtype Ref = Ref { unRef :: Int }

instance Map Ref Patricia.IntMap where func = datatype (EP unRef Ref) idEP



data Perfect a = Zero a | Succ (Perfect (a,a))

-- PTrie m = m :*: PTrie (m :@: m)
newtype PTrie m a = PTrie { unPTrie :: Pair m (PTrie (Comp m m)) a }
instance Map k m => Map (Perfect k) (PTrie m) where
	func = datatype (EP to from) (EP unPTrie PTrie)
		where
			to (Zero k) = Left k
			to (Succ p) = Right p
			
			from = either Zero Succ



----

empty :: Map k m => (k) -> m a
empty = runEmpty func

newtype Empty k m = Empty { runEmpty :: forall a. k -> m a }

instance MapFunc Empty where
	unit = Empty (const Nothing)
	plus = Empty (\(_::Either k1 k2) -> empty (__::k1) :*: empty (__::k2))
	pair = Empty (\(_::(k1,k2)) -> C (empty (__::k1)))
	
	datatype (kep::EP k k') mep = Empty (\_ -> from mep (empty (__::k')))
	
	prim = Empty (const Prim.empty)
	int  = Empty (const Patricia.empty)
	
--

singleton :: Map k m => k -> a -> m a
singleton = runSingle func

newtype Single k m = Single { runSingle :: forall a. k -> a -> m a }

instance MapFunc Single where
	unit = Single (const Just)

	plus = Single (\(k::Either k1 k2) x -> case k of
		Left k1  -> singleton k1 x :*: empty (__::k2)
		Right k2 -> empty (__::k1) :*: singleton k2 x)

	pair = Single (\(k1,k2) -> C . singleton k1 . singleton k2)
	
	datatype kep mep = Single (\k -> from mep . singleton (to kep k))
	
	prim = Single Prim.singleton
	int  = Single Patricia.singleton

--

{-
fromList :: Map k m => (a -> a -> a) -> [(k,a)] -> m a
fromList = runFromList func

newtype FromList k m = FromList { runFromList :: forall a. (a -> a -> a) -> [(k,a)] -> m a }

instance MapFunc FromList where
	unit = FromList (\c xs -> case xs of
		[]       -> Nothing
		(_,x):xs -> Just (foldr (c . snd) x xs))
	
	plus 
-}

fromList c (xs::[(k,a)]) = foldr (\(k,x) -> insertWith c k x) (empty (__::k)) xs

--

insertWith :: Map k m => (a -> a -> a) -> k -> a -> m a -> m a
insertWith = runInsertWith func

newtype InsertWith k m = InsertWith
	{ runInsertWith :: forall a. (a -> a -> a) -> k -> a -> m a -> m a }

instance MapFunc InsertWith where
	unit = InsertWith (\c () x -> Just . maybe x (c x))
	plus = InsertWith (\c k x -> case k of
		Left k1  -> map1 (insertWith c k1 x)
		Right k2 -> map2 (insertWith c k2 x))
	
	pair = InsertWith (\c (k1,k2) x (C m1) ->
		C (insertWith (\_ -> insertWith c k2 x) k1 (singleton k2 x) m1))
	
	datatype kep mep = InsertWith (\c k x -> from mep . insertWith c (to kep k) x . to mep)
	
	prim = InsertWith Prim.insertWith
	int  = InsertWith Patricia.insertWith

--

lookup :: Map k m => k -> m a -> Maybe a
lookup = runLookup func

newtype Lookup k m = Lookup { runLookup :: forall a. k -> m a -> Maybe a }

instance MapFunc Lookup where
	unit = Lookup (\() -> id)
	plus = Lookup (either (\k1 -> lookup k1 . proj1) (\k2 -> lookup k2 . proj2))
	pair = Lookup (\(k1,k2) (C m) -> lookup k1 m >>= lookup k2)
	
	datatype kep mep = Lookup (\k -> lookup (to kep k) . to mep)
	
	prim = Lookup Prim.lookup
	int  = Lookup Patricia.lookup




--

isEmpty :: Map k m => (k) -> m a -> Bool
isEmpty = runIsEmpty func

newtype IsEmpty k m = IsEmpty { runIsEmpty :: forall a. k -> m a -> Bool }

instance MapFunc IsEmpty where
	unit = IsEmpty (\_ -> maybe False (const True))
	plus = IsEmpty (\(_::Either k1 k2) -> fold (&&) (isEmpty (__::k1)) (isEmpty (__::k2)))
	pair = IsEmpty (\(_::(k1,k2)) -> isEmpty (__::k1) . unC)
	
	datatype (kep::EP k k') mep = IsEmpty (\_ -> isEmpty (__::k') . to mep)
	
	prim = IsEmpty (const Prim.null)
	int  = IsEmpty (const Patricia.null)

--

update :: Map k m => (a -> Maybe a) -> k -> m a -> m a
update = runUpdate func

newtype Update k m = Update { runUpdate :: forall a. (a -> Maybe a) -> k ->
m a -> m a }

instance MapFunc Update where
	unit = Update (\f () m -> m >>= f)
	plus = Update (\f -> either (map1 . update f) (map2 . update f))
	pair = Update (\f (k1,k2) -> C . update (justNot (isEmpty k2) . update f k2) k1 . unC)

	datatype kep mep = Update (\f k -> from mep . update f (to kep k) . to mep)
	
	prim = Update Prim.update
	int  = Update Patricia.update

justNot :: (a -> Bool) -> a -> Maybe a
justNot p x = if p x then Nothing else Just x

--

delete :: Map k m => k -> m a -> m a
delete = runDelete func

newtype Delete k m = Delete { runDelete :: forall a. k -> m a -> m a }

instance MapFunc Delete where
	unit = Delete (\_ _ -> Nothing)
	plus = Delete (either (map1 . delete) (map2 . delete))
	pair = Delete (\(k1,k2) -> C . update (justNot (isEmpty k2) . delete k2) k1 . unC)
	
	datatype kep mep = Delete (\k -> from mep . delete (to kep k) . to mep)
	
	prim = Delete Prim.delete
	int  = Delete Patricia.delete

--

toList :: Map k m => m a -> [(k,a)]
toList = runToList func

newtype ToList k m = ToList { runToList :: forall a. m a -> [(k,a)] }

instance MapFunc ToList where
	unit = ToList (maybe [] (\x -> [((),x)]))
	plus = ToList (fold (++) (mapFst Left . toList) (mapFst Right . toList))
		where
			
	pair = ToList (\(C m) -> do
		(k,m') <- toList m
		mapFst ((,) k) (toList m'))
	
	datatype kep mep = ToList (mapFst (from kep) . toList . to mep)
	
	prim = ToList Prim.toList
	int  = ToList Patricia.toList

mapFst f = map (\(k,x) -> (f k, x))

--

elems :: Map k m => (k) -> m a -> [a]
elems = runElems func

newtype Elems k m = Elems { runElems :: forall a. k -> m a -> [a] }

instance MapFunc Elems where
	unit = Elems (\_ -> maybe [] (:[]))
	plus = Elems (\(_::Either k1 k2) -> fold (++) (elems (__::k1)) (elems (__::k2)))
	pair = Elems (\(_::(k1,k2)) (C m) -> elems (__::k1) m >>= elems (__::k2))
	
	datatype (kep::EP k k') mep = Elems (\_ -> elems (__::k') . to mep)
	
	prim = Elems (const Prim.elems)
	int  = Elems (const Patricia.elems)

--

keys :: Map k m => m a -> [k]
keys = runKeys func

newtype Keys k m = Keys { runKeys :: forall a. m a -> [k] }

instance MapFunc Keys where
	unit = Keys (maybe [] (const [()]))
	plus = Keys (fold (++) (map Left . keys) (map Right . keys))
	pair = Keys (\(C m1) -> do
		(k1,m2) <- toList m1
		k2 <- keys m2
		return (k1,k2))
	
	datatype kep mep = Keys (map (from kep) . keys . to mep)
	prim = Keys Prim.keys
	int  = Keys Patricia.keys
	
-- 

size :: Map k m => (k) -> m a -> Int
size = runSize func

newtype Size k m = Size { runSize :: forall a. k -> m a -> Int }

instance MapFunc Size where
	unit = Size (\_ -> maybe 0 (const 1))
	plus = Size (\(_::Either k1 k2) -> fold (+) (size (__::k1)) (size (__::k2)))
	pair = Size (\(_::(k1,k2)) -> sum . map (size (__::k2)) . elems (__::k1) . unC)
	
	datatype (kep::EP k k') mep = Size (\_ -> size (__::k') . to mep)
	prim = Size (const Prim.size)
	int  = Size (const Patricia.size)