{-# LANGUAGE FlexibleInstances, TypeOperators, MultiParamTypeClasses, Rank2Types, GADTs #-}

module Data.TrieMap.MultiRec.Ord where

import Data.TrieMap.MultiRec.Eq
import Data.TrieMap.MultiRec.Base
import Data.TrieMap.Regular.Ord
import Generics.MultiRec

import Data.Monoid

-- type Comparator a = a -> a -> Ordering

class HEq phi f => HOrd phi f where
	compareH :: (forall ix . phi ix -> Comparator (r ix)) -> phi ix -> Comparator (f r ix)

class HEq0 phi r => HOrd0 phi r where
	compare0 :: phi ix -> Comparator (r ix)

hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix)
hcompare = compareH compare0

instance Ord k => HOrd phi (K k) where
	compareH _ _ (K a) (K b) = compare a b

instance El phi xi => HOrd phi (I xi) where
	compareH cmp _ (I a) (I b) = cmp proof a b

instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where
	compareH cmp pf (x1 :*: y1) (x2 :*: y2) = compareH cmp pf x1 x2 `mappend` compareH cmp pf y1 y2

instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where
	compareH cmp pf a b = case (a, b) of
		(L a, L b) -> compareH cmp pf a b
		(R a, R b) -> compareH cmp pf a b
		(L _, R _) -> LT
		_	   -> GT

instance HOrd phi f => HOrd phi (f :>: ix) where
	compareH cmp pf (Tag a) (Tag b) = compareH cmp pf a b

instance HOrd phi U where
	compareH _ _ _ _ = EQ

-- hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix)
-- hcompare = compareH compareH0
-- 
-- class HEq0 phi r => HOrd0 phi r where
-- 	compareH0 :: phi ix -> Comparator (r ix)
-- 
-- -- instance HOrd0 phi r => HOrd0 phi (A0 r) where
-- -- 	compareH0 pf (A0 a) (A0 b) = compareH0 pf a b
-- 
-- -- instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi (A f r) where
-- -- 	compareH0 pf (A a) (A b) = hcompare pf a b
-- 
-- -- instance HOrd phi A0 where
-- -- 	compareH cmp pf (A0 a) (A0 b) = cmp pf a b
-- 
-- instance Ord k => HOrd phi (K k) where
-- 	compareH _ = compareH0
-- 
-- instance Ord k => HOrd0 phi (K k r) where
-- 	compareH0 _ (K a) (K b) = compare a b
-- 
-- instance El phi xi => HOrd phi (I xi) where
-- 	compareH cmp _ (I a) (I b) = cmp proof a b
-- 
-- instance (El phi xi, HOrd0 phi r) => HOrd0 phi (I xi r) where
-- 	compareH0 = hcompare
-- 
-- instance HOrd phi U where
-- 	compareH _ = compareH0
-- 
-- instance HOrd0 phi (U r) where
-- 	compareH0 _ _ _ = EQ
-- 
-- instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where
-- 	compareH cmp pf (x1 :*: y1) (x2 :*: y2) = compareH cmp pf x1 x2 `mappend` compareH cmp pf y1 y2
-- 
-- instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :*: g) r) where
-- 	compareH0 = hcompare
-- 
-- instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where
-- 	compareH cmp pf x y = case (x, y) of
-- 		(L x, L y) -> compareH cmp pf x y
-- 		(R x, R y) -> compareH cmp pf x y
-- 		(L _, R _) -> LT
-- 		(R _, L _) -> GT
-- 
-- instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :+: g) r) where
-- 	compareH0 = hcompare
-- 
-- instance HOrd phi f => HOrd phi (f :>: ix) where
-- 	compareH cmp pf (Tag a) (Tag b) = compareH cmp pf a b
-- 
-- instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi ((f :>: ix) r) where
-- 	compareH0 pf (Tag a) (Tag b) = hcompare pf a b
-- 
-- instance HOrd phi f => HOrd0 phi (HFix f) where
-- 	compareH0 pf (HIn a) (HIn b) = hcompare pf a b