module Generics.MultiRec.Ord where
import Generics.MultiRec
import Data.Monoid (mappend)
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)