{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}

module Generics.MultiRec.Ord where

import Generics.MultiRec
import Data.Monoid (mappend)

--------------------------------------------------------------------------------
-- Generic Ord
--------------------------------------------------------------------------------
class HOrd phi f where
  hcompare :: (forall ix. phi ix -> r ix -> r ix -> Ordering) 
              -> phi ix -> f r ix -> f r ix -> Ordering

instance El phi xi => HOrd phi (I xi) where
  hcompare f _ (I x) (I y) = f proof x y

instance Ord a => HOrd phi (K a) where
  hcompare _ _ (K x) (K y) = compare x y

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

instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where
  hcompare f p (L _) (R _) = LT
  hcompare f p (R _) (L _) = GT
  hcompare f p (L x) (L y) = hcompare f p x y
  hcompare f p (R x) (R y) = hcompare f p x y

instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where
  hcompare f p (v :*: x) (w :*: y) = hcompare f p v w `mappend` hcompare f p x y

instance HOrd phi f => HOrd phi (C c f) where
  hcompare f p (C x) (C y) = hcompare f p x y

instance HOrd phi f => HOrd phi (f :>: ix) where
  hcompare f p (Tag x) (Tag y) = hcompare f p x y

instance (Ord1 f, HOrd phi g) => HOrd phi (f :.: g) where
  hcompare f p (D x) (D y) = compare1 (hcompare f p) x y

class Ord1 f where
  compare1 :: (a -> a -> Ordering) -> f a -> f a -> Ordering

instance Ord1 [] where
  compare1 f [] [] = EQ
  compare1 f [] _  = LT
  compare1 f _  [] = GT
  compare1 f (x:xs) (y:ys) = f x y `mappend` compare1 f xs ys

gcompare :: (Fam phi, HOrd phi (PF phi)) => phi ix -> ix -> ix -> Ordering
gcompare p x1 x2 = hcompare (\ p (I0 x1) (I0 x2) -> gcompare p x1 x2) p (from p x1) (from p x2)