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

module Data.TrieMap.MultiRec.Ord where

import Data.TrieMap.MultiRec.Eq

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)

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 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