{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeOperators #-}

module Data.TrieMap.Regular.Ord where

import Data.TrieMap.Regular.Base
import Data.TrieMap.Regular.Eq

import Data.Monoid

type Comparator a = a -> a -> Ordering

class EqT f => OrdT f where
	compareT0 :: Comparator a -> Comparator (f a)

compareT :: (OrdT f, Ord a) => Comparator (f a)
compareT = compareT0 compare

instance Ord a => OrdT (K0 a) where
	compareT0 _ (K0 a) (K0 b) = compare a b

instance Ord a => Ord (K0 a r) where
	compare (K0 a) (K0 b) = compare a b

instance OrdT I0 where
	compareT0 cmp (I0 a) (I0 b) = cmp a b

instance Ord r => Ord (I0 r) where
	compare = compareT

instance (OrdT f, OrdT g) => OrdT (f :*: g) where
	compareT0 cmp (x1 :*: y1) (x2 :*: y2) = compareT0 cmp x1 x2 `mappend` compareT0 cmp y1 y2

instance (OrdT f, OrdT g, Ord r) => Ord ((f :*: g) r) where
	compare = compareT

instance (OrdT f, OrdT g) => OrdT (f :+: g) where
	compareT0 cmp x y = case (x, y) of
		(L x, L y)	-> compareT0 cmp x y
		(R x, R y)	-> compareT0 cmp x y
		(L _, R _)	-> LT
		(R _, L _)	-> GT

instance (OrdT f, OrdT g, Ord r) => Ord ((f :+: g) r) where
	compare = compareT

instance OrdT U0 where
	compareT0 _ = compare

instance Ord (U0 r) where
	compare _ _ = EQ

instance OrdT f => OrdT (L f) where
	compareT0 cmp (List xs) (List ys) = compareT0' xs ys where
		cmpT' = compareT0 cmp
		compareT0' (x:xs) (y:ys) = cmpT' x y `mappend` compareT0' xs ys
		compareT0' [] [] = EQ
		compareT0' [] _ = LT
		compareT0' _ [] = GT

instance (OrdT f, Ord r) => Ord (L f r) where
	compare = compareT

instance OrdT [] where
	compareT0 cmp = cmpT' where
		cmpT' (x:xs) (y:ys) = cmp x y `mappend` cmpT' xs ys
		cmpT' [] [] = EQ
		cmpT' [] _ = LT
		cmpT' _ [] = GT

instance (Regular a, Functor (PF a), OrdT (PF a)) => Ord (Reg a) where
	compare a b = compareT (from' a) (from' b)